diff options
304 files changed, 11543 insertions, 5111 deletions
diff --git a/.github/workflows/linux-build.yml b/.github/workflows/linux-build.yml index 632070c..02897e9 100644 --- a/.github/workflows/linux-build.yml +++ b/.github/workflows/linux-build.yml @@ -16,7 +16,7 @@ env: ERROR_ON_FAILURES: 1 jobs: build: - runs-on: ubuntu-24.04 + runs-on: ubuntu-22.04 strategy: matrix: compiler: @@ -31,11 +31,11 @@ jobs: - "--enable-symbols" steps: - name: Checkout Tk - uses: actions/checkout@v4 + uses: actions/checkout@v5 with: path: tk - name: Checkout Tcl 9.1 - uses: actions/checkout@v4 + uses: actions/checkout@v5 with: repository: tcltk/tcl ref: main @@ -111,7 +111,7 @@ jobs: echo "VERSION=`ls -d tk* | sed 's/tk//'`" >> $GITHUB_ENV - name: Upload Source Distribution if: ${{ env.BUILD_CONFIG_ID == 'gcc' }} - uses: actions/upload-artifact@v4 + uses: actions/upload-artifact@v5 with: name: Tk ${{ env.VERSION }} Source distribution (snapshot) path: | @@ -119,12 +119,12 @@ jobs: !/tmp/dist/tk*/html/** - name: Upload Documentation Distribution if: ${{ env.BUILD_CONFIG_ID == 'gcc' }} - uses: actions/upload-artifact@v4 + uses: actions/upload-artifact@v5 with: name: Tk ${{ env.VERSION }} HTML documentation (snapshot) path: /tmp/dist/tk*/html test: - runs-on: ubuntu-24.04 + runs-on: ubuntu-22.04 strategy: matrix: compiler: @@ -135,11 +135,11 @@ jobs: - "--enable-symbols" steps: - name: Checkout Tk - uses: actions/checkout@v4 + uses: actions/checkout@v5 with: path: tk - name: Checkout Tcl 9.1 - uses: actions/checkout@v4 + uses: actions/checkout@v5 with: repository: tcltk/tcl ref: main diff --git a/.github/workflows/linux-with-tcl9-build.yml b/.github/workflows/linux-with-tcl9-build.yml index eda0220..1de5992 100644 --- a/.github/workflows/linux-with-tcl9-build.yml +++ b/.github/workflows/linux-with-tcl9-build.yml @@ -16,7 +16,7 @@ env: ERROR_ON_FAILURES: 1 jobs: build: - runs-on: ubuntu-24.04 + runs-on: ubuntu-22.04 strategy: matrix: compiler: @@ -105,7 +105,7 @@ jobs: exit 1 } test: - runs-on: ubuntu-24.04 + runs-on: ubuntu-22.04 strategy: matrix: compiler: diff --git a/.github/workflows/mac-build.yml b/.github/workflows/mac-build.yml index e2abf3c..b39b04a 100644 --- a/.github/workflows/mac-build.yml +++ b/.github/workflows/mac-build.yml @@ -12,18 +12,18 @@ env: ERROR_ON_FAILURES: 1 jobs: framework: - runs-on: macos-15 + runs-on: macos-26 defaults: run: shell: bash working-directory: tk/macosx steps: - name: Checkout Tk - uses: actions/checkout@v4 + uses: actions/checkout@v5 with: path: tk - name: Check out Tcl 9.1 - uses: actions/checkout@v4 + uses: actions/checkout@v5 with: repository: tcltk/tcl ref: main @@ -56,7 +56,7 @@ jobs: fi timeout-minutes: 30 prefix: - runs-on: macos-15 + runs-on: macos-26 strategy: matrix: symbols: @@ -71,11 +71,11 @@ jobs: working-directory: tk/unix steps: - name: Checkout Tk - uses: actions/checkout@v4 + uses: actions/checkout@v5 with: path: tk - name: Check out Tcl 9.1 - uses: actions/checkout@v4 + uses: actions/checkout@v5 with: repository: tcltk/tcl ref: main diff --git a/.github/workflows/onefiledist.yml b/.github/workflows/onefiledist.yml index e4861eb..6a2a8c1 100644 --- a/.github/workflows/onefiledist.yml +++ b/.github/workflows/onefiledist.yml @@ -11,7 +11,7 @@ permissions: jobs: linux: name: Linux - runs-on: ubuntu-24.04 + runs-on: ubuntu-22.04 defaults: run: shell: bash @@ -20,16 +20,16 @@ jobs: CFGOPT: --disable-symbols --disable-shared steps: - name: Checkout Tk - uses: actions/checkout@v4 + uses: actions/checkout@v5 with: path: tk - name: Checkout Tcl 9.1 - uses: actions/checkout@v4 + uses: actions/checkout@v5 with: repository: tcltk/tcl ref: main path: tcl - - name: Setup Environment + - name: Prepare run: | sudo apt-get install libxss-dev libxft-dev touch tcl/generic/tclStubInit.c tcl/generic/tclOOStubInit.c @@ -64,7 +64,7 @@ jobs: env: BUILD_NAME: wish${{ env.TCL_PATCHLEVEL }}_snapshot - name: Upload - uses: actions/upload-artifact@v4 + uses: actions/upload-artifact@v5 with: name: Wish ${{ env.TCL_PATCHLEVEL }} Linux single-file build (snapshot) path: ${{ env.INST_DIR }}/*.tar @@ -75,7 +75,7 @@ jobs: working-directory: ${{ env.INST_DIR }} macos: name: macOS - runs-on: macos-13 + runs-on: macos-15 defaults: run: shell: bash @@ -84,26 +84,29 @@ jobs: CFGOPT: --disable-symbols --disable-shared steps: - name: Checkout Tk - uses: actions/checkout@v4 + uses: actions/checkout@v5 with: path: tk - name: Checkout Tcl 9.1 - uses: actions/checkout@v4 + uses: actions/checkout@v5 with: repository: tcltk/tcl ref: main path: tcl - name: Checkout create-dmg - uses: actions/checkout@v4 + uses: actions/checkout@v5 with: repository: create-dmg/create-dmg - ref: v1.0.8 + ref: v1.2.2 path: create-dmg - - name: Setup Environment + - name: Prepare run: | mkdir -p install/contents - touch tcl/generic/tclStubInit.c tcl/generic/tclOOStubInit.c - touch tk/generic/tkStubInit.c + touch tcl/generic/tclStubInit.c tcl/generic/tclOOStubInit.c || true + touch tk/generic/tkStubInit.c || true + wget https://github.com/culler/macher/releases/download/v1.8/macher + sudo cp macher /usr/local/bin + sudo chmod a+x /usr/local/bin/macher echo "INST_DIR=$(cd install;pwd)" >> $GITHUB_ENV echo "VER_PATH=$(cd tcl/tools; pwd)/addVerToFile.tcl" >> $GITHUB_ENV echo "CREATE_DMG=$(cd create-dmg;pwd)/create-dmg" >> $GITHUB_ENV @@ -152,7 +155,7 @@ jobs: env: BUILD_NAME: wish${{ env.TCL_PATCHLEVEL }}_snapshot - name: Upload - uses: actions/upload-artifact@v4 + uses: actions/upload-artifact@v5 with: name: Wish ${{ env.TCL_PATCHLEVEL }} macOS single-file build (snapshot) path: ${{ env.INST_DIR }}/*.dmg @@ -172,16 +175,16 @@ jobs: msystem: MINGW64 install: git mingw-w64-x86_64-toolchain make zip - name: Checkout Tk - uses: actions/checkout@v4 + uses: actions/checkout@v5 with: path: tk - name: Checkout Tcl 9.1 - uses: actions/checkout@v4 + uses: actions/checkout@v5 with: repository: tcltk/tcl ref: main path: tcl - - name: Setup Environment + - name: Prepare run: | mkdir -p install/combined touch tcl/generic/tclStubInit.c tcl/generic/tclOOStubInit.c @@ -215,7 +218,7 @@ jobs: env: BUILD_NAME: wish${{ env.TCL_PATCHLEVEL }}_snapshot - name: Upload - uses: actions/upload-artifact@v4 + uses: actions/upload-artifact@v5 with: name: Wish ${{ env.TCL_PATCHLEVEL }} Windows single-file build (snapshot) path: install/combined/wish${{ env.TCL_PATCHLEVEL }}_snapshot.exe diff --git a/.github/workflows/win-build.yml b/.github/workflows/win-build.yml index 83a3d06..1df0563 100644 --- a/.github/workflows/win-build.yml +++ b/.github/workflows/win-build.yml @@ -26,11 +26,11 @@ jobs: - "OPTS=static" steps: - name: Checkout Tk - uses: actions/checkout@v4 + uses: actions/checkout@v5 with: path: tk - name: Checkout Tcl 9.1 - uses: actions/checkout@v4 + uses: actions/checkout@v5 with: repository: tcltk/tcl ref: main @@ -118,9 +118,9 @@ jobs: msystem: MINGW64 install: git mingw-w64-x86_64-toolchain make zip - name: Checkout Tk - uses: actions/checkout@v4 + uses: actions/checkout@v5 - name: Checkout Tcl 9.1 - uses: actions/checkout@v4 + uses: actions/checkout@v5 with: repository: tcltk/tcl ref: main @@ -158,7 +158,7 @@ jobs: CFGOPT: --enable-64bit ${{ matrix.config }} - name: Build Tk run: | - make all tktest || { + make all install tktest || { echo "::error::Failure during Build" exit 1 } @@ -1,6 +1,6 @@ # README: Tk -This is the **Tk 9.1a0** source distribution. +This is the **Tk 9.1a1** source distribution. You can get any source release of Tk from [our distribution site](https://sourceforge.net/projects/tcl/files/Tcl/). @@ -23,7 +23,7 @@ cross-platform GUI toolkit implemented with the Tcl scripting language. For details on features, incompatibilities, and potential problems with this release, see [the Tcl/Tk 9.1 Web page](https://www.tcl-lang.org/software/tcltk/9.1.html) or refer to the "changes" file in this directory, which contains a -historical record of all changes to Tk. +description of the changes in Tk 9.1 compared to Tk 9.0 Tk is maintained, enhanced, and distributed freely by the Tcl community. Source code development and tracking of bug reports and feature requests @@ -4,11 +4,11 @@ changes to the Tk source code at > [Tk Source Code](https://core.tcl-lang.org/tk/) -Release Tk 9.1a0 arises from the check-in with tag `core-9.1a0`. +Release Tk 9.1a1 arises from the check-in with tag `core-9-1-a1`. -Tk 9.1a0 continues the Tk 9.x series of releases. The Tk 9.x series +Tk 9.1a1 continues the Tk 9.x series of releases. The Tk 9.x series do not support Tcl 8.6. The Tk 9.1 series extends the Tcl 9.0 series. -To make use of Tk 9.1a0, first a Tcl 9.0 or 9.1 release must be present. +To make use of Tk 9.1a1, first a Tcl 9.0 or 9.1 release must be present. As new Tk features are developed, expect them to appear in Tk 9, but not necessarily in Tk 8. @@ -17,6 +17,13 @@ necessarily in Tk 8. - [Handle negative screen distances](https://core.tcl-lang.org/tips/doc/trunk/tip/698.md) - [Extend Tk_CanvasTextInfo](https://core.tcl-lang.org/tips/doc/trunk/tip/704.md) - [Add new states to ttk::treeview and ttk::notebook](https://core.tcl-lang.org/tips/doc/trunk/tip/719.md) - + - [Limit tk_messageBox to physical screen width](https://core.tcl-lang.org/tk/info/e19f1d891) + - [Constrain own Dialogs to the physical screen size](https://core.tcl-lang.org/tk/info/7c28f835) + - [Add a ttk::toggleswitch widget to the core](https://core.tcl-lang.org/tips/doc/trunk/tip/727.md) + - [Add a tk attribtable command to the core](https://core.tcl-lang.org/tips/doc/trunk/tip/729.md) + - [Implement more X11 region functions on Windows and Aqua](https://core.tcl-lang.org/tk/info/50fdbc36ad) + # Potential incompatibilities to 9.0 - [MS-Win: the undocumented option -xpstyle was removed from tk_chooseDirectory and tk_getOpenFile](https://core.tcl-lang.org/tk/tktview/441c52) + - [MS-Win: The "xpnative" ttk style is gone too, in favor of "vista"](https://core.tcl-lang.org/tk/tktview/441c52) +
\ No newline at end of file diff --git a/compat/stdbool.h b/compat/stdbool.h deleted file mode 100644 index 6e74c58..0000000 --- a/compat/stdbool.h +++ /dev/null @@ -1,37 +0,0 @@ -/*===---- stdbool.h - Standard header for booleans -------------------------=== -* -* Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -* See https://llvm.org/LICENSE.txt for license information. -* SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -* -* Modified for use by pre-C99 compilers. (c) Jan Nijtmans. -* -*===-----------------------------------------------------------------------=== -*/ - -#ifndef __STDBOOL_H -#define __STDBOOL_H - -/* Don't define bool, true, and false in C++, except as a GNU extension. */ -#ifndef __cplusplus -#if defined(__STDC_VERSION__) && (__STDC_VERSION__ >= 199901L) -#define bool _Bool -#else -#define bool unsigned char -#endif -#define true 1 -#define false 0 -#elif defined(__GNUC__) && !defined(__STRICT_ANSI__) -/* Define _Bool as a GNU extension. */ -#define _Bool bool -#if __cplusplus < 201103L -/* For C++98, define bool, false, true as a GNU extension. */ -#define bool bool -#define false false -#define true true -#endif -#endif - -#define __bool_true_false_are_defined 1 - -#endif /* __STDBOOL_H */ diff --git a/doc/CrtItemType.3 b/doc/CrtItemType.3 index a019972..6615168 100644 --- a/doc/CrtItemType.3 +++ b/doc/CrtItemType.3 @@ -85,9 +85,9 @@ typedef struct Tk_ItemType { Tk_ItemInsertProc *\fIinsertProc\fR; Tk_ItemDCharsProc *\fIdCharsProc\fR; struct Tk_ItemType *\fInextPtr\fR; -.VS "8.7, TIP164" +.VS "9.0, TIP164" Tk_ItemRotateProc *\fIrotateProc\fR; -.VE "8.7, TIP164" +.VE "9.0, TIP164" } \fBTk_ItemType\fR; .CE .PP @@ -539,7 +539,7 @@ added to each x and y coordinate within the item. The type manager should adjust the item's coordinates and update the bounding box in the item's header. .SS ROTATEPROC -.VS "8.7, TIP164" +.VS "9.0, TIP164" .PP \fItypePtr\->rotateProc\fR is invoked by Tk to rotate a canvas item during the \fBrotate\fR widget command. @@ -577,7 +577,7 @@ instead be derived from them. Item types do not need to provide a \fItypePtr\->rotateProc\fR. If the \fItypePtr\->rotateProc\fR is NULL, the \fItypePtr\->coordProc\fR will be used instead to retrieve and update the list of coordinates. -.VE "8.7, TIP164" +.VE "9.0, TIP164" .SS INDEXPROC .PP \fItypePtr\->indexProc\fR is invoked by Tk to translate a string diff --git a/doc/CrtPhImgFmt.3 b/doc/CrtPhImgFmt.3 index 6f89ef7..332939c 100644 --- a/doc/CrtPhImgFmt.3 +++ b/doc/CrtPhImgFmt.3 @@ -18,17 +18,17 @@ Tk_CreatePhotoImageFormat \- define new file format for photo images .nf \fB#include <tk.h>\fR .sp -.VS 8.7 +.VS 9.0 \fBTk_CreatePhotoImageFormatVersion3\fR(\fIformatVersion3Ptr\fR) -.VE 8.7 +.VE 9.0 .sp \fBTk_CreatePhotoImageFormat\fR(\fIformatPtr\fR) .SH ARGUMENTS .AS "const Tk_PhotoImageFormatVersion3" *formatVersion3Ptr -.VS 8.7 +.VS 9.0 .AP "const Tk_PhotoImageFormatVersion3" *formatVersion3Ptr in Structure that defines the new file format including metadata functionality. -.VE 8.7 +.VE 9.0 .AP "const Tk_PhotoImageFormat" *formatPtr in Structure that defines the new file format. .BE @@ -56,7 +56,7 @@ plus a \fBTk_PhotoImageFormatVersion3\fR structure, which contains the name of the image file format and pointers to six procedures provided by the handler to deal with files and strings in this format. The Tk_PhotoImageFormatVersion3 structure contains the following fields: -.VS 8.7 +.VS 9.0 .CS typedef struct { const char *\fIname\fR; @@ -68,7 +68,7 @@ typedef struct { Tk_ImageStringWriteProcVersion3 *\fIstringWriteProc\fR; } \fBTk_PhotoImageFormatVersion3\fR; .CE -.VE 8.7 +.VE 9.0 .PP The handler need not provide implementations of all six procedures. For example, the procedures that handle string data would not be @@ -91,7 +91,7 @@ the \fB\-format\fR option. The first character of \fIformatPtr->name\fR must not be an uppercase character from the ASCII character set (that is, one of the characters \fBA\fR-\fBZ\fR). Such names are used only for legacy interface support (see below). -.VS 8.7 +.VS 9.0 .SS FILEMATCHPROC .PP \fIformatPtr->fileMatchProc\fR provides the address of a procedure for @@ -358,7 +358,7 @@ metadata within the driver. For example, the creation of an expensive metadata key may depend on a format string option or on a metadata input key. .PP -.VE 8.7 +.VE 9.0 .SH "VERSION 2 INTERFACE" .PP Version 2 Interface does not include the possibility for the driver to diff --git a/doc/SetOptions.3 b/doc/SetOptions.3 index d0c6c06..5c4b62f 100644 --- a/doc/SetOptions.3 +++ b/doc/SetOptions.3 @@ -546,7 +546,7 @@ typedef int \fBTk_CustomOptionSetProc\fR( Tk_Window \fItkwin\fR, Tcl_Obj **\fIvaluePtr\fR, char *\fIrecordPtr\fR, - int \fIinternalOffset\fR, + Tcl_Size \fIinternalOffset\fR, char *\fIsaveInternalPtr\fR, int \fIflags\fR); @@ -554,7 +554,7 @@ typedef Tcl_Obj *\fBTk_CustomOptionGetProc\fR( void *\fIclientData\fR, Tk_Window \fItkwin\fR, char *\fIrecordPtr\fR, - int \fIinternalOffset\fR); + Tcl_Size \fIinternalOffset\fR); typedef void \fBTk_CustomOptionRestoreProc\fR( void *\fIclientData\fR, diff --git a/doc/attribtable.n b/doc/attribtable.n new file mode 100644 index 0000000..02b5e71 --- /dev/null +++ b/doc/attribtable.n @@ -0,0 +1,154 @@ +.\" +.\" Copyright (c) 2025 Csaba Nemethi +.\" +.\" See the file "license.terms" for information on usage and redistribution +.\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +.\" +.TH tk attribtable n 9.1 "" Tk "Tk Built-in Commands" +.so man.macros +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +tk attribtable \- Create an attribute table, used to query and modify +arbitrary data attached to any widget. +.SH SYNOPSIS +\fBtk attribtable \fItableName\fR +.BE +.SH DESCRIPTION +.PP +This command creates an attribute table of the name \fItableName\fR, +implemented as a hash table and accessible as a command in the namespace of +the calling context if not fully qualified, and returns the fully qualified +name of the command just created. +.PP +An attribute table is used to query and modify arbitrary data attached to any +widget. These data are commonly called \fIattributes\fR. +.PP +If an attribute table of the given name already exists then it is replaced +with the new one and all the attributes of all widgets set using the old table +instance will be unset. +.PP +\fBREMARK 1:\fR When the \fItableName\fR command is deleted (via \fBrename\fR +\fItableName\fR "" or by deleting the containing namespace), all the +attributes of all widgets set using this command are automatically unset and +the underlying hash table is deleted. This will free all the memory used by +the table. +.PP +\fBREMARK 2:\fR When a widget is destroyed, all of its attributes set by all +attribute table commands are automatically unset. This will free all the +memory used by the widget's attributes. +.PP +The command \fItableName\fR created by this command has the signature +.PP +.CS +\fItableName\fR \fBset\fR|\fBget\fR|\fBunset\fR|\fBclear\fR|\fBexists\fR|\fBnames\fR|\fBpathnames\fR \fIargs\fR +.CE +.PP +In the description of the supported forms below, \fIpathName\fR specifies a +widget whose attributes are being queried or modified via the \fItableName\fR +command. +.\" METHOD: set +.TP +\fItableName\fR \fBset\fR \fIpathName name value\fR ?\fIname value\fR ...? +. +Sets (i.e., adds or updates) the attributes identified by the \fIname\fR +arguments to the values given by the \fIvalue\fR arguments. Returns an empty +string. Example: +.RS +.PP +.CS +# Save and then change the button's text +\fBtk attribtable\fR table +table \fBset\fR .btn prevText [.btn cget -text] +\&.btn configure -text "NewText" +.CE +.RE +.\" METHOD: get +.TP +\fItableName\fR \fBget\fR \fIpathName\fR ?\fIname\fR ?\fIdefaultValue\fR?? +. +If \fIname\fR is specified then returns the corresponding attribute value, or +an empty string or \fIdefaultValue\fR (if given) if no corresponding value +exists. Otherwise returns a list consisting of all attribute names and values +of the widget \fIpathName\fR. Example: +.RS +.PP +.CS +# Restore the button's previous text +\&.btn configure -text [table \fBget\fR .btn prevText] +.CE +.RE +.\" METHOD: unset +.TP +\fItableName\fR \fBunset\fR \fIpathName name\fR ?\fIname\fR ...? +. +Unsets the attributes identified by the \fIname\fR arguments. Returns an +empty string. Example: +.RS +.PP +.CS +table \fBunset\fR .btn prevText +.CE +.RE +.\" METHOD: clear +.TP +\fItableName\fR \fBclear\fR \fIpathName\fR +. +Unsets all attributes and removes \fIpathName\fR from the list of those +widgets that have attributes set via \fItableName\fR \fBset\fR. Returns an +empty string. Example: +.RS +.PP +.CS +table \fBclear\fR .btn +.CE +.RE +.\" METHOD: exists +.TP +\fItableName\fR \fBexists\fR \fIpathName\fR ?\fIname\fR? +. +If the optional argument is present then returns \fB1\fR if the attribute +identified by \fIname\fR exists and \fB0\fR otherwise. Without the optional +argument the return value is \fB1\fR if the widget \fIpathName\fR has at +least one attribute set via \fItableName\fR \fBset\fR and \fB0\fR otherwise. +Example: +.RS +.PP +.CS +if [table \fBexists\fR .btn prevText] { + # Restore the button's previous text + \&.btn configure -text [table \fBget\fR .btn prevText] +} +.CE +.RE +.\" METHOD: names +.TP +\fItableName\fR \fBnames\fR \fIpathName\fR +. +Returns a list consisting of all attribute names of the widget +\fIpathName\fR. Example: +.RS +.PP +.CS +puts "attribute names for .btn: [table \fBnames\fR .btn]" +.CE +.RE +.\" METHOD: pathnames +.TP +\fItableName\fR \fBpathnames\fR +. +Returns a list consisting of the path names of all widgets that have +attributes set via \fItableName\fR \fBset\fR. +Example: +.RS +.PP +.CS +puts "widgets in table: [table \fBpathnames\fR]" +.CE +.RE +.SH KEYWORDS +widget, attribute, attribute table +.\" Local Variables: +.\" mode: nroff +.\" fill-column: 78 +.\" End: diff --git a/doc/canvas.n b/doc/canvas.n index 2942358..986ad2a 100644 --- a/doc/canvas.n +++ b/doc/canvas.n @@ -221,9 +221,9 @@ Canvases do not support scaling or rotation of the canvas coordinate system relative to the window coordinate system. .PP Individual items may be moved, scaled -.VS "8.7, TIP164" +.VS "9.0, TIP164" or rotated -.VE "8.7, TIP164" +.VE "9.0, TIP164" using widget commands described below. .PP @@ -1016,7 +1016,7 @@ use as a replacement). The other items ignore this operation. .\" METHOD: rotate .TP \fIpathName \fBrotate \fItagOrId xOrigin yOrigin angle\fR -.VS "8.7, TIP164" +.VS "9.0, TIP164" Rotate the coordinates of all of the items given by \fItagOrId\fR in canvas coordinate space. \fIXOrigin\fR and \fIyOrigin\fR identify the origin for the rotation @@ -1034,7 +1034,7 @@ computed center point instead of moving the bounding box coordinates directly. Some items (currently \fBarc\fR and\fB text\fR) have angles in their options; this command \fIdoes not\fR affect those options. .RE -.VE "8.7, TIP164" +.VE "9.0, TIP164" .\" METHOD: scale .TP \fIpathName \fBscale \fItagOrId xOrigin yOrigin xScale yScale\fR diff --git a/doc/frame.n b/doc/frame.n index 27d3b5a..e7d7eed 100644 --- a/doc/frame.n +++ b/doc/frame.n @@ -25,7 +25,7 @@ except that its value may also be specified as an empty string. In this case, the widget will display no background or border, and no colors will be consumed from its colormap for its background and border. -.VS "8.7, TIP262" +.VS "9.0, TIP262" An empty background will disable drawing the background image. .OP \-backgroundimage backgroundImage BackgroundImage This specifies an image to display on the frame's background within @@ -34,7 +34,7 @@ frame's highlight ring and border, if either are present); subwidgets of the frame will be drawn on top. The image must have been created with the \fBimage create\fR command. If specified as the empty string, no image will be displayed. -.VE "8.7, TIP262" +.VE "9.0, TIP262" .OP \-class class Class Specifies a class for the window. This class will be used when querying the option database for @@ -73,14 +73,14 @@ not added. Normally \fB\-height\fR should not be used if a propagating geometry manager, such as \fBgrid\fR or \fBpack\fR, is used within the frame since the geometry manager will override the height of the frame. .OP \-tile tile Tile -.VS "8.7, TIP262" +.VS "9.0, TIP262" This specifies how to draw the background image (see \fB\-backgroundimage\fR) on the frame. If true (according to \fBTcl_GetBoolean\fR), the image will be tiled to fill the whole frame, with the origin of the first copy of the image being the top left of the interior of the frame. If false (the default), the image will be centered within the frame. -.VE "8.7, TIP262" +.VE "9.0, TIP262" .OP \-visual visual Visual Specifies visual information for the new window in any of the forms accepted by \fBTk_GetVisual\fR. diff --git a/doc/photo.n b/doc/photo.n index 676c70e..f5d3861 100644 --- a/doc/photo.n +++ b/doc/photo.n @@ -44,9 +44,9 @@ procedural interface. At present, only PNG, .VE 8.6 GIF, PPM/PGM, -.VS 8.7 +.VS 9.0 and (read-only) SVG -.VE 8.7 +.VE 9.0 formats are supported, but an interface exists to allow additional image file formats to be added easily. A photo image is (semi)transparent if the image data it was obtained from had @@ -63,10 +63,10 @@ Photos support the following \fIoptions\fR: \fB\-data \fIstring\fR . Specifies the contents of the image as a string. -.VS 8.7 +.VS 9.0 The string should contain data in the default list-of-lists form, -.VE 8.7 +.VE 9.0 binary data or, for some formats, base64-encoded data (this is currently guaranteed to be supported for PNG and GIF images). The format of the string must be one of those for which there is an image @@ -110,7 +110,7 @@ Specifies the height of the image, in pixels. This option is useful primarily in situations where the user wishes to build up the contents of the image piece by piece. A value of zero (the default) allows the image to expand or shrink vertically to fit the data stored in it. -.VS 8.7 +.VS 9.0 .\" OPTION: -metadata .TP \fB\-metadata \fImetadata\fR @@ -120,7 +120,7 @@ Additional keys may be set within the metadata dictionary of the image, if image data is processed due to a \fB\-file\fR or \fB\-data\fR options and the driver outputs any metadata keys. See section \fBMETADATA DICTIONARY\fR below. -.VE 8.7 +.VE 9.0 .\" OPTION: -palette .TP \fB\-palette \fIpalette-spec\fR @@ -195,10 +195,10 @@ modifies the given option(s) to have the given value(s); in this case the command returns an empty string. \fIOption\fR may have any of the values accepted by the \fBimage create\fR \fBphoto\fR command. -.VS 8.7 +.VS 9.0 Note that setting the \fB\-metadata\fR option without any other option will not invoke the image format driver to recreate the bitmap. -.VE 8.7 +.VE 9.0 .\" METHOD: copy .TP \fIimageName \fBcopy\fI sourceImage\fR ?\fIoption value(s) ...\fR? @@ -278,12 +278,12 @@ the source image is used as-is. The default compositing rule is \fIimageName \fBdata\fR ?\fIoption value(s) ...\fR? . Returns image data in the form of a string. -.VS 8.7 +.VS 9.0 The format of the string depends on the format handler. By default, a human readable format as a list of lists of pixel data is used, other formats can be chosen with the \fB\-format\fR option. See \fBIMAGE FORMATS\fR below for details. -.VE 8.7 +.VE 9.0 The following options may be specified: .RS .\" OPTION: -background @@ -302,13 +302,13 @@ optionally, arguments to the format handler. Specifically, this subcommand searches for the first handler whose name matches an initial substring of \fIformat-name\fR and which has the capability to write a string containing this image data. -.VS 8.7 +.VS 9.0 If this option is not given, this subcommand uses the default format that consists of a list (one element per row) of lists (one element per pixel/column) of colors in .QW \fB#\fIrrggbb\fR format (see \fBIMAGE FORMATS\fR below). -.VE 8.7 +.VE 9.0 Note that the value of this option must be a Tcl list. This means that the braces may be omitted if the argument has only one word. Also, instead of braces, double quotes may be used for quoting. @@ -329,7 +329,7 @@ whole image. . If this options is specified, the data will not contain color information. All pixel data will be transformed into grayscale. -.VS 8.7 +.VS 9.0 .\" OPTION: -metadata .TP \fB\-metadata\fI metadata\fR @@ -340,7 +340,7 @@ The specified \fImetadata\fR is passed to the driver for inclusion in the data. If no \fB\-metadata\fR option is given, the current metadata of the image is used. -.VE 8.7 +.VE 9.0 .RE .\" METHOD: get .TP @@ -357,12 +357,12 @@ representing the alpha value of the pixel as an integer between 0 and \fIimageName \fBput\fI data\fR ?\fIoption value(s) ...\fR? . Sets pixels in \fI imageName\fR to the data specified in \fIdata\fR. -.VS 8.7 +.VS 9.0 This command searches the list of image file format handlers for a handler that can interpret the data in \fIdata\fR, and then reads the image encoded within into \fIimageName\fR (the destination image). See \fBIMAGE FORMATS\fR below for details on formats for image data. -.VE 8.7 +.VE 9.0 The following options may be specified: .RS .\" OPTION: -format @@ -377,7 +377,7 @@ format handler to read the data. Note that the value of this option must be a Tcl list. This means that the braces may be omitted if the argument has only one word. Also, instead of braces, double quotes may be used for quoting. -.VS 8.7 +.VS 9.0 .\" OPTION: -metadata .TP \fB\-metadata\fI metadata\fR @@ -386,7 +386,7 @@ A specified \fImetadata\fR is passed to the image format driver when interpretin the data. Note that the current metadata of the image is not passed to the format driver and is not changed by the command. -.VE 8.7 +.VE 9.0 .\" OPTION: -to .TP \fB\-to \fIx1 y1\fR ?\fIx2 y2\fR? @@ -436,7 +436,7 @@ corner of the image in the image file. If all four coordinates are specified, they specify diagonally opposite corners or the region. The default, if this option is not specified, is the whole of the image in the image file. -.VS 8.7 +.VS 9.0 .\" OPTION: -metadata .TP \fB\-metadata\fI metadata\fR @@ -445,7 +445,7 @@ A specified \fImetadata\fR is passed to the image format driver when interpretin the data. Note that the current metadata of the image is not passed to the format driver and is not changed by the command. -.VE 8.7 +.VE 9.0 .\" OPTION: -shrink .TP \fB\-shrink\fR @@ -484,21 +484,21 @@ the photo image. Several subcommands are available: .RS .TP \fIimageName \fBtransparency get \fIx y\fR ?\fB\-alpha\fR? -.VS 8.7 +.VS 9.0 Returns true if the pixel at (\fIx\fR,\fIy\fR) is fully transparent, false otherwise. If the option \fB\-alpha\fR is passed, returns the alpha value of the pixel instead, as an integer in the range 0 to 255. -.VE 8.7 +.VE 9.0 .TP \fIimageName \fBtransparency set \fIx y newVal\fR ?\fB\-alpha\fR? -.VS 8.7 +.VS 9.0 Change the transparency of the pixel at (\fIx\fR,\fIy\fR) to \fInewVal.\fR If no additional option is passed, \fInewVal\fR is interpreted as a boolean and the pixel is made fully transparent if that value is true, fully opaque otherwise. If the \fB\-alpha\fR option is passed, \fInewVal\fR is interpreted as an integral alpha value for the pixel, which must be in the range 0 to 255. -.VE 8.7 +.VE 9.0 .RE .\" METHOD: write .TP @@ -545,7 +545,7 @@ if this option is not given, is the whole image. . If this options is specified, the data will not contain color information. All pixel data will be transformed into grayscale. -.VS 8.7 +.VS 9.0 .\" OPTION: -metadata .TP \fB\-metadata\fI metadata\fR @@ -555,7 +555,7 @@ The specified \fImetadata\fR is passed to the driver for inclusion in the file. If no \fB\-metadata\fR option is given, the current metadata of the image is used. -.VE 8.7 +.VE 9.0 .RE .SH "IMAGE FORMATS" .PP @@ -565,10 +565,10 @@ a list of these handlers. Handlers are added to the list by registering them with a call to \fBTk_CreatePhotoImageFormat\fR. The standard Tk distribution comes with handlers for PPM/PGM, PNG, GIF and (read-only) SVG formats, -.VS 8.7 +.VS 9.0 as well as the \fBdefault\fR handler to encode/decode image data in a human readable form. -.VE 8.7 +.VE 9.0 These handlers are automatically registered on initialization. .PP When reading an image file or processing string data specified with @@ -592,7 +592,7 @@ that, which the handler can use, for example, to specify which variant to use of the formats supported by the handler. Note that not all image handlers may support writing transparency data to a file, even where the target image format does. -.VS 8.7 +.VS 9.0 .SS "THE DEFAULT IMAGE HANDLER" .PP The \fBdefault\fR image handler cannot be used to read or write data @@ -608,7 +608,7 @@ list of scan-lines, with each scan-line being a (left-to-right) list of pixel data. Every scan-line has the same length. The color and, optionally, alpha value of each pixel is specified in any of the forms described in the \fBCOLOR FORMATS\fR section below. -.VE 8.7 +.VE 9.0 .SS "FORMAT SUBOPTIONS" .PP @@ -620,7 +620,7 @@ string. The nature and values of these options is up to the format handler. The built-in handlers support these suboptions: .\" OPTION -colorformat -.VS 8.7 +.VS 9.0 .TP \fBdefault \-colorformat\fI formatType\fR . @@ -631,7 +631,7 @@ encode pixel data in the form \fB#\fIRRGGBB\fR, \fBrgba\fR to encode pixel data in the form \fB#\fIRRGGBBAA\fR or \fBlist\fR to encode pixel data as a list with four elements. See \fBCOLOR FORMATS\fR below for details. The default is \fBrgb\fR. -.VE 8.7 +.VE 9.0 .\" OPTION -index .TP \fBgif \-index\fI indexValue\fR @@ -732,7 +732,7 @@ format) photos is supported: Tk does not (yet) support bundling photo images in SVG vector graphics. .RE .VE 8.6 -.VS 8.7 +.VS 9.0 .SH "COLOR FORMATS" .PP The default image handler can represent/parse color and alpha values @@ -778,7 +778,7 @@ channels respectively. Each digit will be expanded internally to \fB#\fR\fIRRGGBBAA\fR format: \fB#\fR followed by eight hexadecimal digits, where each pair of subsequent digits represents the value for the red, green, blue and alpha channels respectively. -.VE 8.7 +.VE 9.0 .SH "COLOR ALLOCATION" .PP When a photo image is displayed in a window, the photo image code @@ -808,7 +808,7 @@ each primary color to try to allocate. It can also be used to force the image to be displayed in shades of gray, even on a color display, by giving a single number rather than three numbers separated by slashes. -.VS 8.7 +.VS 9.0 .SH "METADATA DICTIONARY" .PP Each image has a metadata dictionary property. @@ -861,7 +861,7 @@ Otherwise, the key is not present. Update region of the current subimage, if subimage has not the same size as the full image. The pixel outside of this box are all fully transparent. .PP -.VE 8.7 +.VE 9.0 .SH CREDITS .PP The photo image type was designed and implemented by Paul Mackerras, @@ -897,7 +897,7 @@ button .b -image icon -disabledimage iconDisabled .CE .VE 8.6 .PP -.VS 8.7 +.VS 9.0 Create a green box with a simple shadow effect .PP .CS @@ -911,7 +911,7 @@ for {set i 14} {$i > 0} {incr i -1} { # Put a solid green rectangle on top foo \fBput\fR #F080 -to 0 0 30 30 -.VE 8.7 +.VE 9.0 .CE .SH "SEE ALSO" image(n) @@ -90,6 +90,11 @@ they use some other form of authorization such as that provide by \fBxauth\fR. Under Windows, \fBsend\fR is currently disabled. Most of the functionality is provided by the \fBdde\fR command instead. +.SH LIMITATIONS +.PP +Under macOS/aqua, the send command works only with interpreters that exist in +the same process (these are returned by "winfo interps"). Invocations that +target an interpreter that exists in another process don't accomplish anything. .SH EXAMPLE .PP This script fragment can be used to make an application that only runs @@ -35,7 +35,8 @@ the undo stack. Only meaningful when the \fB\-undo\fR option is true. .OP \-blockcursor blockCursor BlockCursor Specifies a boolean that says whether the blinking insertion cursor should be drawn as a character-sized rectangular block. If false (the default) a thin -vertical line is used for the insertion cursor. +vertical line is used for the insertion cursor. For further discussion +refer to section \fBTHE INSERTION CURSOR\fR below. .OP \-endline endLine EndLine Specifies an integer line index representing the line of the underlying textual data store that should be just after the last line contained in @@ -917,6 +918,13 @@ with the widget command. The \fBinsert\fR mark represents the position of the insertion cursor, and the insertion cursor will automatically be drawn at this point whenever the text widget has the input focus. +.PP +The \fB\-blockcursor\fR widget option controls the drawing of the cursor. +However, drawing the cursor as a solid blinking block is not exactly +performed as in real or emulated terminals. The character at the cursor +position is always drawn in it's foreground color, i.e. not in +"reverse video", which can lead to unwanted visual effects and even +hide the character entirely, when the cursor is in its on-state. .SH "THE MODIFIED FLAG" .PP The text widget can keep track of changes to the content of the widget by @@ -45,13 +45,21 @@ be able to find some options for the application. If sends have been disabled by deleting the \fBsend\fR command, this command will reenable them and recreate the \fBsend\fR command. +.\" METHOD: attribtable +.TP +\fBtk attribtable \fItableName\fR +. +This command creates an attribute table of the name \fItableName\fR as a +command in the namespace of the calling context if not fully qualified. An +attribute table is used to query and modify arbitrary data attached to any +widget. For more details see the \fBattribtable\fR manual page. .\" METHOD: busy .TP \fBtk busy \fIsubcommand\fR ... . This command controls the marking of window hierarchies as .QW busy , -rendering them non-interactive while some other operation is proceeding. For +rendering them non-interactive while some other operation is proceeding. For more details see the \fBbusy\fR manual page. .\" METHOD: caret .TP @@ -71,7 +79,7 @@ of the specified \fIwindow\fR if none is given. \fBtk inactive \fR?\fB\-displayof \fIwindow\fR? ?\fBreset\fR? . Returns a positive integer, the number of milliseconds since the last -time the user interacted with the system. If the \fB\-displayof\fR +time the user interacted with the system. If the \fB\-displayof\fR option is given then the return value refers to the display of \fIwindow\fR; otherwise it refers to the display of the application's main window. @@ -81,7 +89,7 @@ main window. is not supported by the system, and in safe interpreters. .PP If the literal string \fBreset\fR is given as an additional argument, -the timer is reset and an empty string is returned. Resetting the +the timer is reset and an empty string is returned. Resetting the inactivity time is forbidden in safe interpreters and will throw an error if tried. .RE @@ -89,15 +97,15 @@ error if tried. .TP \fBtk fontchooser \fIsubcommand\fR ... . -Controls the Tk font selection dialog. For more details see the +Controls the Tk font selection dialog. For more details see the \fBfontchooser\fR manual page. .\" METHOD: print .TP \fBtk print \fIwindow\fR . The \fBtk print\fR command posts a dialog that allows users to print output -from the \fBcanvas\fR and \fBtext\fR widgets. The printing will be done using -platform-native APIs and dialogs where available. For more details see the +from the \fBcanvas\fR and \fBtext\fR widgets. The printing will be done using +platform-native APIs and dialogs where available. For more details see the \fBprint\fR manual page. .\" METHOD: scaling .TP @@ -127,25 +135,25 @@ accommodate the new scaling factor. .RE .\" METHOD: sysnotify .TP -\fBtk sysnotify \fP \fItitle\fP? \fImessage\fP? +\fBtk sysnotify \fItitle message\fR . The \fBtk sysnotify\fP command creates a platform-specific system -notification alert. Its intent is to provide a brief, unobtrusive +notification alert. Its intent is to provide a brief, unobtrusive notification to the user by popping up a window that briefly appears in a -corner of the screen. For more details see the \fBsysnotify\fR manual page. +corner of the screen. For more details see the \fBsysnotify\fR manual page. .\" METHOD: systray .TP -\fBtk systray create\fP \fIsubcommand...\fP +\fBtk systray \fIsubcommand\fR ... . The \fBtk systray\fP command creates an icon in the platform-specific -tray. For more details see the \fBsystray\fR manual page. +tray. For more details see the \fBsystray\fR manual page. .\" METHOD: useinputmethods .TP \fBtk useinputmethods \fR?\fB\-displayof \fIwindow\fR? ?\fIboolean\fR? . Sets and queries the state of whether Tk should use XIM (X Input Methods) for filtering events. The resulting state is returned. XIM is used in -some locales (i.e., Japanese, Korean), to handle special input devices. This +some locales (i.e., Japanese, Korean), to handle special input devices. This feature is only significant on X. If XIM support is not available, this will always return 0. If the \fIwindow\fR argument is omitted, it defaults to the main window. If the \fIboolean\fR argument is omitted, the current @@ -158,9 +166,10 @@ Returns the current Tk windowing system, one of \fBx11\fR (X11-based), \fBwin32\fR (MS Windows), or \fBaqua\fR (macOS Aqua). .SH "SEE ALSO" -busy(n), fontchooser(n), print(n), send(n), sysnotify(n), systray(n), winfo(n) +attribtable(n), busy(n), fontchooser(n), print(n), send(n), sysnotify(n), +systray(n), winfo(n) .SH KEYWORDS -application name, print, send, sysnotify, systray +application name, attribute, print, send, sysnotify, systray '\" Local Variables: '\" mode: nroff '\" End: diff --git a/doc/tk_mac.n b/doc/tk_mac.n index 7af9606..15b1134 100644 --- a/doc/tk_mac.n +++ b/doc/tk_mac.n @@ -27,6 +27,7 @@ tk::mac \- Access Mac-Specific Functionality on macOS from Tk \fB::tk::mac::PerformService\fR \fB::tk::mac::LaunchURL \fIURL...\fR \fB::tk::mac::GetAppPath\fR +\fB::tk::mac::GetInfoAsJSON\fR \fB::tk::mac::standardAboutPanel\fR @@ -36,6 +37,7 @@ tk::mac \- Access Mac-Specific Functionality on macOS from Tk \fB::tk::mac::useThemedToplevel \fIboolean\fR \fB::tk::mac::iconBitmap \fIname width height \-kind value\fR + .fi .BE .SH "EVENT HANDLER CALLBACKS" @@ -220,6 +222,11 @@ customized for the specific URL scheme the developer wants to support. \fB::tk::mac::GetAppPath\fR . Returns the current applications's file path. +.TP +\fB::tk::mac::GetInfoAsJSON\fR +. +Returns a JSON-encoded Tcl string which serializes the application's +\fBmainBundle.infoDictionary\fR (defined by its \fIInfo.plist\fR file). .PP .SH "ADDITIONAL DIALOGS" .PP diff --git a/doc/toplevel.n b/doc/toplevel.n index 701d383..2fee87c 100644 --- a/doc/toplevel.n +++ b/doc/toplevel.n @@ -25,7 +25,7 @@ except that its value may also be specified as an empty string. In this case, the widget will display no background or border, and no colors will be consumed from its colormap for its background and border. -.VS "8.7, TIP262" +.VS "9.0, TIP262" An empty background will disable drawing the background image. .OP \-backgroundimage backgroundImage BackgroundImage This specifies an image to display on the toplevel's background within @@ -35,7 +35,7 @@ the background; subwidgets of the toplevel will be drawn on top. The image must have been created with the \fBimage create\fR command. If specified as the empty string, no image will be displayed. -.VE "8.7, TIP262" +.VE "9.0, TIP262" .OP \-class class Class Specifies a class for the window. This class will be used when querying the option database for @@ -85,14 +85,14 @@ This option is special in that it may not be specified via the option database, and it may not be modified with the \fBconfigure\fR widget command. .OP \-tile tile Tile -.VS "8.7, TIP262" +.VS "9.0, TIP262" This specifies how to draw the background image (see \fB\-backgroundimage\fR) on the toplevel. If true (according to \fBTcl_GetBoolean\fR), the image will be tiled to fill the whole toplevel, with the origin of the first copy of the image being the top left of the interior of the toplevel. If false (the default), the image will be centered within the toplevel. -.VE "8.7, TIP262" +.VE "9.0, TIP262" .OP \-use use Use This option is used for embedding. If the value is not an empty string, it must be the window identifier of a container window, specified as diff --git a/doc/ttk_toggleswitch.n b/doc/ttk_toggleswitch.n new file mode 100644 index 0000000..49914ac --- /dev/null +++ b/doc/ttk_toggleswitch.n @@ -0,0 +1,268 @@ +.\" +.\" Copyright (c) 2025 Csaba Nemethi +.\" +.\" See the file "license.terms" for information on usage and redistribution +.\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +.\" +.TH ttk::toggleswitch n 9.1 Tk "Tk Themed Widget" +.so man.macros +.BS +.SH NAME +ttk::toggleswitch \- Create and manipulate a toggleswitch widget +.SH SYNOPSIS +\fBttk::toggleswitch \fIpathName \fR?\fIoptions...\fR? +.BE +.SH DESCRIPTION +.PP +A \fBttk::toggleswitch\fR widget is used to show or change a binary setting. +It consists of a horizontal \fItrough\fR (a fully rounded filled rectangle) +and a \fIslider\fR (a filled circle contained in the trough). Their +dimensions depend on the display's scaling level, the current theme, and the +value of the \fB-size\fR configuration option. +.PP +Just like a light switch, a toggleswitch widget can have one of two possible +\fIswitch state\fRs: on or off. In the on state the slider is placed at the +end of the trough, and in the off state at its beginning. The user can toggle +between these two states with the mouse or the space key. +.PP +The colors used when drawing the trough and slider in the various widget +states depend on the current theme. If the theme is \fBaqua\fR then they also +depend on the system appearance (light mode or dark mode) and the accent +color, and are automatically adapted whenever one of these global system +settings changes. +.PP +The implementation creates these elements when needed with the aid of generic +code for arbitrary themes and theme-specific one for a few built-in themes. +Applications can add \fIexplicit\fR support for any theme \fItheme\fR by +providing an appropriate command of the name +\fBttk::toggleswitch::CreateElements_\fR\fItheme\fR. +.SO ttk_widget +\-class \-cursor \-style +\-takefocus +.SE +.PP +The default value of the \fB-class\fR option is \fBToggleswitch\fR. The value +of the \fB-style\fR option defaults to \fBToggleswitch2\fR, corresponding to +the \fB-size\fR option's default value \fB2\fR (see below). +.SH "WIDGET-SPECIFIC OPTIONS" +.OP \-command command Command +Specifies a Tcl script to be evaluated at global scope whenever the switch +state of the widget is toggled (programmatically, by invoking the +\fBswitchstate\fR or \fBtoggle\fR subcommand, or interactively). The default +is an empty string. +.OP \-offvalue offValue OffValue +The value to store in the associated \fB\-variable\fR +when the widget's switch state is set to off. Defaults to \fB0\fR. +.OP \-onvalue onValue OnValue +The value to store in the associated \fB\-variable\fR +when the widget's switch state is set to on. Defaults to \fB1\fR. +.OP \-size size Size +Specifies the size identifier of the toggleswitch widget. The supported +values are the strings \fB1\fR, \fB2\fR (the default), and \fB3\fR. In the +case of the \fBaqua\fR theme, these size IDs correspond to the control sizes +"mini", "small", and "large" of the native toggle switches on macOS. +.RS +.PP +Note that by setting this option to a value \fIsize\fR, the \fB-style\fR +option's value will automatically change to \fBToggleswitch\fR\fIsize\fR if +its previous or requested value was \fBToggleswitch1\fR, \fBToggleswitch2\fR, +or \fBToggleswitch3\fR, and to \fIprefix\fR.\fBToggleswitch\fR\fIsize\fR if +its previous or requested value was \fIprefix\fR.\fBToggleswitch1\fR, +\fIprefix\fR.\fBToggleswitch2\fR, or \fIprefix\fR.\fBToggleswitch3\fR. +Conversely, by setting the \fB-style\fR option to a value of the form +\fBToggleswitch\fR\fIsize\fR or \fIprefix\fR.\fBToggleswitch\fR\fIsize\fR +(where \fIsize\fR is one of \fB1\fR, \fB2\fR, or \fB3\fR), the \fB-size\fR +option will automatically be set to \fIsize\fR. When configuring both options +\fB-size\fR and \fB-style\fR, the former will take precedence over the latter, +regardless of the order in which they were specified. +.PP +For example, if you create the widget with +.PP +.CS +\fBttk::toggleswitch\fR \fIpathName\fR \fB-size 3 -style\fR My.\fBToggleswitch3\fR +.CE +.PP +or invoke +.PP +.CS +\fIpathName\fR \fBconfigure -style\fR My.\fBToggleswitch3\fR +.CE +.PP +then the \fB-style\fR option will be set to My.\fBToggleswitch3\fR (and the +\fB-size\fR option will have the value \fB3\fR). On the other hand, if you +create the widget with +.PP +.CS +\fBttk::toggleswitch\fR \fIpathName\fR \fB-style\fR My.\fBToggleswitch3\fR +.CE +.PP +then the \fB-style\fR option will have the value My.\fBToggleswitch2\fR rather +than My.\fBToggleswitch3\fR, because the widget creation triggers the default +\fB-size 2\fR setting, which takes precedence over \fB-style\fR +My.\fBToggleswitch3\fR. +.RE +.OP \-variable variable Variable +The name of a global variable whose value is linked to the toggleswitch. The +widget's switch state changes to on when this variable is set to the value +specified by the \fB-onvalue\fR option and to off otherwise. Defaults to the +widget's pathname if not specified. +.RS +.PP +Note that, just like in the case of the (ttk::)checkbutton, toggling the +widget's switch state by changing the value of this variable will \fInot\fR +cause the script specified by the \fB-command\fR option to get executed. +.RE +.SH "WIDGET COMMAND" +.PP +In addition to the standard +\fBcget\fR, \fBconfigure\fR, \fBidentify element\fR, \fBinstate\fR, +\fBstate\fR, and \fBstyle\fR commands (see \fBttk::widget\fR), toggleswitch +widgets support the following additional commands: +.\" METHOD: switchstate +.TP +\fIpathName \fBswitchstate \fR?\fIboolean\fR? +. +Modifies or inquires the widget's switch state. If the optional argument is +present then it must be a boolean (a numeric value, where 0 is false and +anything else is true, or a string such as \fBtrue\fR/\fByes\fR/\fBon\fR or +\fBfalse\fR/\fBno\fR/\fBoff\fR). If the widget's \fBdisabled\fR state flag is +set then the command returns an empty string immediately after checking the +argument. Otherwise, if the argument is true then the command sets the +widget's switch state to on by setting its \fBselected\fR flag, moving the +slider to the end of the trough, and setting the associated \fB-variable\fR to +the value specified by the \fB-onvalue\fR option; if the argument is false +then the command sets the widget's switch state to off by clearing the +\fBselected\fR flag, moving the slider to the beginning of the trough, and +setting the associated variable to the value specified by the \fB-offvalue\fR +option. +.RS +.PP +If the argument's value causes the widget's switch state to get toggled and +the script specified as the value of the \fB-command\fR option is a nonempty +string then the command evaluates that script at global scope and returns its +result; otherwise the return value is an empty string. +.PP +If the optional argument is not present then the command returns the widget's +current switch state as \fB0\fR (off) or \fB1\fR (on). When a toggleswitch +widget is created, its switch state is initialized with \fB0\fR. +.RE +.\" METHOD: toggle +.TP +\fIpathName \fBtoggle\fR +. +This convenience subcommand toggles the widget's switch state. It is +logically equivalent to invoking the \fBswitchstate\fR command with the +argument \fB0\fR if the current switch state is on and with the argument +\fB1\fR otherwise. +.SH "INTERNAL COMMANDS" +.PP +The following widget commands are used internally by the \fBToggleswitch\fR +widget class bindings. They provide a means to access the widget's internal +value, which is a real number within a certain invariant interval. +.\" METHOD: get +.TP +\fIpathName \fBget \fR?\fBmin\fR|\fBmax\fR|\fIx\fR? +. +Returns the current/minimum/maximum internal value, or the one corresponding +to the coordinate \fIx\fR relative to the widget origin if it is specified. +.\" METHOD: set +.TP +\fIpathName \fBset \fIvalue\fR +. +Sets the widget's internal value to \fIvalue\fR. The value will be clipped to +the range given by the minimum and maximum values, as returned by +\fBget min\fR and \fBget max\fR. +.PP +.\" METHOD: xcoord +.TP +\fIpathName \fBxcoord \fR?\fIvalue\fR? +. +Returns the x coordinate corresponding to \fIvalue\fR, or to the current +internal value if \fIvalue\fR is omitted. +.SH "DEFAULT BINDINGS" +.PP +The toggleswitch widget's default bindings enable the following behavior. +.PP +If the current theme is \fBaqua\fR: +.IP \0\(bu 4 +By pressing mouse button 1 over the slider and then dragging the mouse with +button 1 down until the pointer enters the trough, the slider moves smoothly +to the opposite edge of the trough and the widget's switch state gets +toggled. The same happens if mouse button 1 is pressed outside the slider and +then the pointer leaves the widget horizontally with button 1 down. +.IP \0\(bu 4 +By pressing mouse button 1 anywhere within the widget and then releasing it +over the widget without previously moving the slider, the latter moves +smoothly to the opposite edge of the trough and the widget's switch state gets +toggled. +.IP \0\(bu 4 +When the widget has the input focus, the space key causes its switch state to +get toggled. +.PP +If the current theme is different from \fBaqua\fR: +.IP \0\(bu 4 +By pressing mouse button 1 anywhere within the widget and then dragging the +mouse with button 1 down, the slider moves in the same (horizontal) direction +as the pointer. By releasing the button, the switch state is set to off or +on, depending on the slider's position relative to the middle of the widget. +.IP \0\(bu 4 +By pressing mouse button 1 anywhere within the widget and then releasing it +over the widget without previously dragging the mouse horizontally, the +widget's switch state gets toggled. +.IP \0\(bu 4 +When the widget has the input focus, the space key causes its switch state to +get toggled. +.PP +If the widget's \fBdisabled\fR state flag is set then none of the above +actions occur. +.SH "WIDGET STATES" +.PP +The widget sets the \fBselected\fR state whenever the switch state changes to +on and clears it otherwise. The widget sets the \fBinvalid\fR state whenever +the linked \fB\-variable\fR is unset. The defalt bindings set and clear the +\fBactive\fR and \fBpressed\fR state flags. +.SH "STYLING OPTIONS" +.PP +The default class name for a \fBttk::toggleswitch\fP is \fBToggleswitch\fP. +.PP +Dynamic states: \fBactive\fP, \fBbackground\fP, \fBdisabled\fP, \fBinvalid\fP, +\fBpressed\fP, \fBselected\fP. +.PP +\fBToggleswitch1\fP, \fBToggleswitch2\fP, and \fBToggleswitch3\fP styling +options configurable with \fBttk::style\fP are: +.PP +\fB\-focuscolor\fP \fIcolor\fP +.RS +The default is theme-specific. +.RE +.br +\fB\-focussolid\fP \fIboolean\fP +.RS +Defaults to true for the \fBclassic\fP theme and false for all the others. +.RE +.br +\fB\-focusthickness\fP \fIamount\fP +.RS +The default is 1. The value may have any of the forms acceptable to +\fBTk_GetPixels\fP. +.RE +.br +\fB\-padding\fP \fIpadding\fP +.RS +Defaults to 1.5p for the \fBaqua\fP theme (for which the three above-mentioned +styles have no \fBfocus\fP element) and 0.75p for all the other themes. +.RE +.PP +For the \fBaqua\fP theme only the \fB\-padding\fP option is available, the +others are simply ignored. +.PP +See the \fBttk_style\fP manual page for information on how to configure ttk +styles. +.SH "SEE ALSO" +ttk::widget(n), ttk::style(n), ttk::checkbutton(n), checkbutton(n). +.SH KEYWORDS +toggleswitch, trough, slider, widget +.\" Local Variables: +.\" mode: nroff +.\" fill-column: 78 +.\" End: diff --git a/doc/ttk_vsapi.n b/doc/ttk_vsapi.n index 4b7e3cc..1e0b8fa 100644 --- a/doc/ttk_vsapi.n +++ b/doc/ttk_vsapi.n @@ -16,8 +16,8 @@ ttk_vsapi \- Define a Microsoft Visual Styles element .PP The \fBvsapi\fR element factory creates a new element in the current theme whose visual appearance is drawn using the -Microsoft Visual Styles API which is responsible for the themed styles -on Windows XP and Vista. This factory permits any of the Visual +Microsoft Visual Styles API which is used in ttk for the MS-Windows +native styles. This factory permits any of the Visual Styles parts to be declared as Ttk elements that can then be included in a style layout to modify the appearance of Ttk widgets. .PP diff --git a/generic/nanosvg.h b/generic/nanosvg.h index ab71443..648a8e7 100644 --- a/generic/nanosvg.h +++ b/generic/nanosvg.h @@ -139,6 +139,12 @@ enum NSVGflags { NSVG_FLAGS_VISIBLE = 0x01 }; +enum NSVGpaintOrder { + NSVG_PAINT_FILL = 0x00, + NSVG_PAINT_MARKERS = 0x01, + NSVG_PAINT_STROKE = 0x02 +}; + typedef struct NSVGgradientStop { unsigned int color; float offset; @@ -183,6 +189,7 @@ typedef struct NSVGshape char strokeLineCap; /* Stroke cap type. */ float miterLimit; /* Miter limit */ char fillRule; /* Fill rule, see NSVGfillRule. */ + unsigned char paintOrder; /* Encoded paint order (3×2-bit fields) see NSVGpaintOrder */ unsigned char flags; /* Logical or of NSVG_FLAGS_* flags */ float bounds[4]; /* Tight bounding box of the shape [minx,miny,maxx,maxy]. */ char fillGradient[64]; // Optional 'id' of fill gradient @@ -475,6 +482,7 @@ typedef struct NSVGattrib char hasFill; char hasStroke; char visible; + unsigned char paintOrder; } NSVGattrib; typedef struct NSVGstyles @@ -661,6 +669,10 @@ static void nsvg__curveBounds(float* bounds, float* curve) } } +static unsigned char nsvg__encodePaintOrder(enum NSVGpaintOrder a, enum NSVGpaintOrder b, enum NSVGpaintOrder c) { + return (a & 0x03) | ((b & 0x03) << 2) | ((c & 0x03) << 4); +} + static NSVGparser* nsvg__createParser(void) { NSVGparser* p; @@ -688,6 +700,7 @@ static NSVGparser* nsvg__createParser(void) p->attr[0].fillRule = NSVG_FILLRULE_NONZERO; p->attr[0].hasFill = 1; p->attr[0].visible = NSVG_VIS_DISPLAY | NSVG_VIS_VISIBLE; + p->attr[0].paintOrder = nsvg__encodePaintOrder(NSVG_PAINT_FILL, NSVG_PAINT_STROKE, NSVG_PAINT_MARKERS); return p; @@ -1032,6 +1045,7 @@ static void nsvg__addShape(NSVGparser* p) shape->miterLimit = attr->miterLimit; shape->fillRule = attr->fillRule; shape->opacity = attr->opacity; + shape->paintOrder = attr->paintOrder; shape->paths = p->plist; p->plist = NULL; @@ -1810,6 +1824,24 @@ static char nsvg__parseFillRule(const char* str) return NSVG_FILLRULE_NONZERO; } +static unsigned char nsvg__parsePaintOrder(const char* str) +{ + if (strcmp(str, "normal") == 0 || strcmp(str, "fill stroke markers") == 0) + return nsvg__encodePaintOrder(NSVG_PAINT_FILL, NSVG_PAINT_STROKE, NSVG_PAINT_MARKERS); + else if (strcmp(str, "fill markers stroke") == 0) + return nsvg__encodePaintOrder(NSVG_PAINT_FILL, NSVG_PAINT_MARKERS, NSVG_PAINT_STROKE); + else if (strcmp(str, "markers fill stroke") == 0) + return nsvg__encodePaintOrder(NSVG_PAINT_MARKERS, NSVG_PAINT_FILL, NSVG_PAINT_STROKE); + else if (strcmp(str, "markers stroke fill") == 0) + return nsvg__encodePaintOrder(NSVG_PAINT_MARKERS, NSVG_PAINT_STROKE, NSVG_PAINT_FILL); + else if (strcmp(str, "stroke fill markers") == 0) + return nsvg__encodePaintOrder(NSVG_PAINT_STROKE, NSVG_PAINT_FILL, NSVG_PAINT_MARKERS); + else if (strcmp(str, "stroke markers fill") == 0) + return nsvg__encodePaintOrder(NSVG_PAINT_STROKE, NSVG_PAINT_MARKERS, NSVG_PAINT_FILL); + /* TODO: handle inherit. */ + return nsvg__encodePaintOrder(NSVG_PAINT_FILL, NSVG_PAINT_STROKE, NSVG_PAINT_MARKERS); +} + static const char* nsvg__getNextDashItem(const char* s, char* it) { int n = 0; @@ -1924,6 +1956,8 @@ static int nsvg__parseAttr(NSVGparser* p, const char* name, const char* value) attr->stopOpacity = nsvg__parseOpacity(value); } else if (strcmp(name, "offset") == 0) { attr->stopOffset = nsvg__parseCoordinate(p, value, 0.0f, 1.0f); + } else if (strcmp(name, "paint-order") == 0) { + attr->paintOrder = nsvg__parsePaintOrder(value); } else if (strcmp(name, "id") == 0) { strncpy(attr->id, value, 63); attr->id[63] = '\0'; diff --git a/generic/nanosvgrast.h b/generic/nanosvgrast.h index b4fac60..b0bc2e1 100644 --- a/generic/nanosvgrast.h +++ b/generic/nanosvgrast.h @@ -971,7 +971,11 @@ static void nsvg__fillActiveEdges(unsigned char* scanline, int len, NSVGactiveEd } } -static float nsvg__clampf(float a, float mn, float mx) { return a < mn ? mn : (a > mx ? mx : a); } +static float nsvg__clampf(float a, float mn, float mx) { + if (isnan(a)) + return mn; + return a < mn ? mn : (a > mx ? mx : a); +} static unsigned int nsvg__RGBA(unsigned char r, unsigned char g, unsigned char b, unsigned char a) { @@ -1391,6 +1395,8 @@ void nsvgRasterize(NSVGrasterizer* r, NSVGedge *e = NULL; NSVGcachedPaint cache; int i; + int j; + unsigned char paintOrder; r->bitmap = dst; r->width = w; @@ -1409,58 +1415,61 @@ void nsvgRasterize(NSVGrasterizer* r, for (shape = image->shapes; shape != NULL; shape = shape->next) { if (!(shape->flags & NSVG_FLAGS_VISIBLE)) continue; + for (j = 0; j < 3; j++) { + paintOrder = (shape->paintOrder >> (2 * j)) & 0x03; + + if (paintOrder == NSVG_PAINT_FILL && shape->fill.type != NSVG_PAINT_NONE) { + nsvg__resetPool(r); + r->freelist = NULL; + r->nedges = 0; + + nsvg__flattenShape(r, shape, scale); + + /* Scale and translate edges */ + for (i = 0; i < r->nedges; i++) { + e = &r->edges[i]; + e->x0 = tx + e->x0; + e->y0 = (ty + e->y0) * NSVG__SUBSAMPLES; + e->x1 = tx + e->x1; + e->y1 = (ty + e->y1) * NSVG__SUBSAMPLES; + } - if (shape->fill.type != NSVG_PAINT_NONE) { - nsvg__resetPool(r); - r->freelist = NULL; - r->nedges = 0; + /* Rasterize edges */ + if (r->nedges != 0) + qsort(r->edges, r->nedges, sizeof(NSVGedge), nsvg__cmpEdge); - nsvg__flattenShape(r, shape, scale); + /* now, traverse the scanlines and find the intersections on each scanline, use non-zero rule */ + nsvg__initPaint(&cache, &shape->fill, shape->opacity); - /* Scale and translate edges */ - for (i = 0; i < r->nedges; i++) { - e = &r->edges[i]; - e->x0 = tx + e->x0; - e->y0 = (ty + e->y0) * NSVG__SUBSAMPLES; - e->x1 = tx + e->x1; - e->y1 = (ty + e->y1) * NSVG__SUBSAMPLES; + nsvg__rasterizeSortedEdges(r, tx,ty,scale, &cache, shape->fillRule); } + if (paintOrder == NSVG_PAINT_STROKE && shape->stroke.type != NSVG_PAINT_NONE && (shape->strokeWidth * scale) > 0.01f) { + nsvg__resetPool(r); + r->freelist = NULL; + r->nedges = 0; + + nsvg__flattenShapeStroke(r, shape, scale); + +/* dumpEdges(r, "edge.svg"); */ + + /* Scale and translate edges */ + for (i = 0; i < r->nedges; i++) { + e = &r->edges[i]; + e->x0 = tx + e->x0; + e->y0 = (ty + e->y0) * NSVG__SUBSAMPLES; + e->x1 = tx + e->x1; + e->y1 = (ty + e->y1) * NSVG__SUBSAMPLES; + } - /* Rasterize edges */ - if (r->nedges != 0) - qsort(r->edges, r->nedges, sizeof(NSVGedge), nsvg__cmpEdge); + /* Rasterize edges */ + if (r->nedges != 0) + qsort(r->edges, r->nedges, sizeof(NSVGedge), nsvg__cmpEdge); - /* now, traverse the scanlines and find the intersections on each scanline, use non-zero rule */ - nsvg__initPaint(&cache, &shape->fill, shape->opacity); + /* now, traverse the scanlines and find the intersections on each scanline, use non-zero rule */ + nsvg__initPaint(&cache, &shape->stroke, shape->opacity); - nsvg__rasterizeSortedEdges(r, tx,ty,scale, &cache, shape->fillRule); - } - if (shape->stroke.type != NSVG_PAINT_NONE && (shape->strokeWidth * scale) > 0.01f) { - nsvg__resetPool(r); - r->freelist = NULL; - r->nedges = 0; - - nsvg__flattenShapeStroke(r, shape, scale); - -/* dumpEdges(r, "edge.svg"); */ - - /* Scale and translate edges */ - for (i = 0; i < r->nedges; i++) { - e = &r->edges[i]; - e->x0 = tx + e->x0; - e->y0 = (ty + e->y0) * NSVG__SUBSAMPLES; - e->x1 = tx + e->x1; - e->y1 = (ty + e->y1) * NSVG__SUBSAMPLES; + nsvg__rasterizeSortedEdges(r, tx,ty,scale, &cache, NSVG_FILLRULE_NONZERO); } - - /* Rasterize edges */ - if (r->nedges != 0) - qsort(r->edges, r->nedges, sizeof(NSVGedge), nsvg__cmpEdge); - - /* now, traverse the scanlines and find the intersections on each scanline, use non-zero rule */ - nsvg__initPaint(&cache, &shape->stroke, shape->opacity); - - nsvg__rasterizeSortedEdges(r, tx,ty,scale, &cache, NSVG_FILLRULE_NONZERO); } } diff --git a/generic/tk.h b/generic/tk.h index c855ddf..9267cff 100644 --- a/generic/tk.h +++ b/generic/tk.h @@ -72,10 +72,10 @@ extern "C" { #endif # define TK_MINOR_VERSION 1 # define TK_RELEASE_LEVEL TCL_ALPHA_RELEASE -# define TK_RELEASE_SERIAL 0 +# define TK_RELEASE_SERIAL 1 # define TK_VERSION "9.1" -# define TK_PATCH_LEVEL "9.1a0" +# define TK_PATCH_LEVEL "9.1a1" /* * A special definition used to allow this header file to be included from @@ -1535,7 +1535,7 @@ typedef Tcl_Size (Tk_SelectionProc) (void *clientData, Tcl_Size offset, *---------------------------------------------------------------------- */ -#include "tkDecls.h" +#include "tkDecls.h" /* IWYU pragma: export */ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT diff --git a/generic/tkClipboard.c b/generic/tkClipboard.c index b8d1a96..276e690 100644 --- a/generic/tkClipboard.c +++ b/generic/tkClipboard.c @@ -394,7 +394,7 @@ Tk_ClipboardAppend( cbPtr->buffer = (char *)ckalloc(cbPtr->length + 1); strcpy(cbPtr->buffer, buffer); - TkSelUpdateClipboard((TkWindow *) dispPtr->clipWindow, targetPtr); + TkSelUpdateClipboard((TkWindow *) dispPtr->clipWindow, CLIPBOARD_APPEND); return TCL_OK; } @@ -426,9 +426,9 @@ Tk_ClipboardObjCmd( Tk_Window tkwin = (Tk_Window)clientData; const char *path = NULL; Atom selection; - static const char *const optionStrings[] = { "append", "clear", "get", NULL }; - enum options { CLIPBOARD_APPEND, CLIPBOARD_CLEAR, CLIPBOARD_GET }; - int index, i; + static const char *const optionStrings[] = { + "append", "clear", "get", NULL }; + int index, i, result; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); @@ -440,7 +440,7 @@ Tk_ClipboardObjCmd( return TCL_ERROR; } - switch ((enum options) index) { + switch ((clipboardOption) index) { case CLIPBOARD_APPEND: { Atom target, format; const char *targetName = NULL; @@ -543,13 +543,16 @@ Tk_ClipboardObjCmd( if (tkwin == NULL) { return TCL_ERROR; } - return Tk_ClipboardClear(interp, tkwin); + result = Tk_ClipboardClear(interp, tkwin); + if (result == TCL_OK) { + TkSelUpdateClipboard((TkWindow *) tkwin, CLIPBOARD_CLEAR); + } + return result; } case CLIPBOARD_GET: { Atom target; const char *targetName = NULL; Tcl_DString selBytes; - int result; const char *string; static const char *const getOptionStrings[] = { "-displayof", "-type", NULL diff --git a/generic/tkCmds.c b/generic/tkCmds.c index ac636d7..0735ea8 100644 --- a/generic/tkCmds.c +++ b/generic/tkCmds.c @@ -36,18 +36,23 @@ static void WaitWindowProc(void *clientData, XEvent *eventPtr); static int AppnameCmd(void *dummy, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const *objv); +static int AttribtableCmd(void *dummy, Tcl_Interp *interp, + Tcl_Size objc, Tcl_Obj *const *objv); +static int AttribTableProc(void *dummy, Tcl_Interp *interp, + Tcl_Size objc, Tcl_Obj *const *objv); +static void AttribTableDeleteProc(void *dummy); +static void AttribTableDestroyHandler(void *dummy, + XEvent *eventPtr); static int CaretCmd(void *dummy, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const *objv); static int InactiveCmd(void *dummy, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const *objv); static int ScalingCmd(void *dummy, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const *objv); -static int UseinputmethodsCmd(void *dummy, - Tcl_Interp *interp, Tcl_Size objc, - Tcl_Obj *const *objv); -static int WindowingsystemCmd(void *dummy, - Tcl_Interp *interp, Tcl_Size objc, - Tcl_Obj *const *objv); +static int UseinputmethodsCmd(void *dummy, Tcl_Interp *interp, + Tcl_Size objc, Tcl_Obj *const *objv); +static int WindowingsystemCmd(void *dummy, Tcl_Interp *interp, + Tcl_Size objc, Tcl_Obj *const *objv); #if defined(_WIN32) || defined(MAC_OSX_TK) MODULE_SCOPE const TkEnsemble tkFontchooserEnsemble[]; @@ -62,6 +67,7 @@ MODULE_SCOPE const TkEnsemble tkFontchooserEnsemble[]; static const TkEnsemble tkCmdMap[] = { {"fontchooser", NULL, tkFontchooserEnsemble}, {"appname", AppnameCmd, NULL }, + {"attribtable", AttribtableCmd, NULL }, {"busy", Tk_BusyObjCmd, NULL }, {"caret", CaretCmd, NULL }, {"inactive", InactiveCmd, NULL }, @@ -664,8 +670,8 @@ TkInitTkCmd( /* *---------------------------------------------------------------------- * - * AppnameCmd, CaretCmd, ScalingCmd, UseinputmethodsCmd, - * WindowingsystemCmd, InactiveCmd -- + * AppnameCmd, AttribtableCmd, CaretCmd, InactiveCmd, ScalingCmd, + * UseinputmethodsCmd, WindowingsystemCmd -- * * These functions are invoked to process the "tk" ensemble subcommands. * See the user documentation for details on what they do. @@ -710,6 +716,422 @@ AppnameCmd( return TCL_OK; } +typedef struct AttribTableData { + Tcl_HashTable *tablePtr; +} AttribTableData; + +typedef struct AttribTableValue { + Tk_Window tkwin; + Tcl_HashTable *tablePtr; + Tcl_Obj *dictPtr; +} AttribTableValue; + +int +AttribtableCmd( + TCL_UNUSED(void *), /* Main window associated with interpreter. */ + Tcl_Interp *interp, /* Current interpreter. */ + Tcl_Size objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + const char *tableName; + Tcl_Size nameLen; + Tcl_DString dsCmdName; + const char *cmdName; + AttribTableData *tblData; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "tableName"); + return TCL_ERROR; + } + + /* + * Get tableName and build the fully qualified name cmdName from it + */ + + tableName = Tcl_GetStringFromObj(objv[1], &nameLen); + Tcl_DStringInit(&dsCmdName); + if (nameLen < 2 || tableName[0] != ':' || tableName[1] != ':') { + Tcl_Namespace *curNs = Tcl_GetCurrentNamespace(interp); + + Tcl_DStringAppend(&dsCmdName, curNs->fullName, TCL_INDEX_NONE); + if (strlen(curNs->fullName) != 2) { + Tcl_DStringAppend(&dsCmdName, "::", TCL_INDEX_NONE); + } + } + Tcl_DStringAppend(&dsCmdName, tableName, TCL_INDEX_NONE); + cmdName = Tcl_DStringValue(&dsCmdName); + + /* + * Create an attribute table command of the name cmdName + */ + + tblData = (AttribTableData *)ckalloc(sizeof(AttribTableData)); + tblData->tablePtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(tblData->tablePtr, TCL_ONE_WORD_KEYS); + + Tcl_CreateObjCommand2(interp, cmdName, + AttribTableProc, tblData, AttribTableDeleteProc); + + Tcl_SetObjResult(interp, Tcl_NewStringObj(cmdName, TCL_INDEX_NONE)); + Tcl_DStringFree(&dsCmdName); + + return TCL_OK; +} + +/* + * Called whenever the attribute table is invoked as command. + */ + +int +AttribTableProc( + void *clientData, /* Pointer to an AttribTableData struct. */ + Tcl_Interp *interp, /* Current interpreter. */ + Tcl_Size objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + AttribTableData *tblData = (AttribTableData *)clientData; + static const char *const optionStrings[] = { + "set", "get", "unset", "clear", "exists", "names", "pathnames", NULL + }; + enum options { + TABLE_SET, TABLE_GET, TABLE_UNSET, TABLE_CLEAR, + TABLE_EXISTS, TABLE_NAMES, TABLE_PATHNAMES + }; + int index; + Tk_Window tkwin; /* Used in all subcommands except the last. */ + Tcl_HashEntry *entryPtr; /* Used in all subcommands. */ + AttribTableValue *value; /* Used in all subcommands. */ + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, + "set|get|unset|clear|exists|names|pathnames args"); + return TCL_ERROR; + } + + if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "subcommand", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + + if (objc > 2) { + tkwin = Tk_NameToWindow(interp, Tcl_GetString(objv[2]), + Tk_MainWindow(interp)); + if (tkwin == NULL) { + if (index == TABLE_EXISTS || index == TABLE_PATHNAMES) { + Tcl_ResetResult(interp); + } else { + return TCL_ERROR; + } + } + } + + switch ((enum options) index) { + case TABLE_SET: { + int isNew; + Tcl_Size i; + + if (objc < 5 || objc % 2 == 0) { + Tcl_WrongNumArgs(interp, 2, objv, + "pathName name value ?name value ...?"); + return TCL_ERROR; + } + + entryPtr = Tcl_CreateHashEntry(tblData->tablePtr, tkwin, &isNew); + if (isNew) { + /* + * Create an AttribTableValue struct and insert it into the table. + */ + + value = (AttribTableValue *)ckalloc(sizeof(AttribTableValue)); + value->tkwin = tkwin; + value->tablePtr = tblData->tablePtr; + value->dictPtr = Tcl_NewDictObj(); + Tcl_IncrRefCount(value->dictPtr); + Tcl_SetHashValue(entryPtr, value); + + /* + * Arrange for AttribTableDestroyHandler to be invoked + * when the window identified by tkwin gets destroyed. + */ + + Tk_CreateEventHandler(tkwin, StructureNotifyMask, + AttribTableDestroyHandler, value); + } else { + value = (AttribTableValue *)Tcl_GetHashValue(entryPtr); + if (Tcl_IsShared(value->dictPtr)) { + /* + * For Tcl_DictObjPut below the dictionary must not be shared. + */ + + Tcl_DecrRefCount(value->dictPtr); + value->dictPtr = Tcl_DuplicateObj(value->dictPtr); + Tcl_IncrRefCount(value->dictPtr); + } + } + + for (i = 3; i < objc; i += 2) { + Tcl_DictObjPut(NULL, value->dictPtr, objv[i], objv[i+1]); + } + break; + } + + case TABLE_GET: { + if (objc < 3 || objc > 5) { + Tcl_WrongNumArgs(interp, 2, objv, + "pathName ?name ?defaultValue??"); + return TCL_ERROR; + } + + entryPtr = Tcl_FindHashEntry(tblData->tablePtr, tkwin); + if (entryPtr != NULL) { + value = Tcl_GetHashValue(entryPtr); + } + + if (objc == 3) { + if (entryPtr != NULL) { + Tcl_SetObjResult(interp, value->dictPtr); + } + } else { + Tcl_Obj *defaultValuePtr = (objc == 5 ? objv[4] : Tcl_NewObj()); + + if (entryPtr == NULL) { + Tcl_SetObjResult(interp, defaultValuePtr); + } else { + Tcl_Obj *resultPtr; + + Tcl_DictObjGet(NULL, value->dictPtr, objv[3], &resultPtr); + if (resultPtr == NULL) { + resultPtr = defaultValuePtr; + } + Tcl_SetObjResult(interp, resultPtr); + } + } + break; + } + + case TABLE_UNSET: { + Tcl_Size i; + + if (objc < 4) { + Tcl_WrongNumArgs(interp, 2, objv, "pathName name ?name ...?"); + return TCL_ERROR; + } + + entryPtr = Tcl_FindHashEntry(tblData->tablePtr, tkwin); + if (entryPtr == NULL) { + return TCL_OK; + } + + value = (AttribTableValue *)Tcl_GetHashValue(entryPtr); + if (Tcl_IsShared(value->dictPtr)) { + /* + * For Tcl_DictObjRemove below the dictionary must not be shared. + */ + + Tcl_DecrRefCount(value->dictPtr); + value->dictPtr = Tcl_DuplicateObj(value->dictPtr); + Tcl_IncrRefCount(value->dictPtr); + } + + for (i = 3; i < objc; i++) { + Tcl_DictObjRemove(NULL, value->dictPtr, objv[i]); + } + break; + } + + case TABLE_CLEAR: { + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "pathName"); + return TCL_ERROR; + } + + entryPtr = Tcl_FindHashEntry(tblData->tablePtr, tkwin); + if (entryPtr == NULL) { + return TCL_OK; + } + + /* + * Delete the event handler associated with value->tkwin. + */ + + value = (AttribTableValue *)Tcl_GetHashValue(entryPtr); + Tk_DeleteEventHandler(value->tkwin, StructureNotifyMask, + AttribTableDestroyHandler, value); + + /* + * Remove the entry from the hash table. + */ + + Tcl_DecrRefCount(value->dictPtr); + Tcl_DeleteHashEntry(entryPtr); + ckfree(value); + break; + } + + case TABLE_EXISTS: { + Tcl_Obj *resultPtr; + + if (objc != 3 && objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "pathName ?name?"); + return TCL_ERROR; + } + + if (tkwin == NULL) { + resultPtr = Tcl_NewIntObj(0); + } else { + entryPtr = Tcl_FindHashEntry(tblData->tablePtr, tkwin); + if (entryPtr == NULL) { + resultPtr = Tcl_NewIntObj(0); + } else { + value = Tcl_GetHashValue(entryPtr); + if (objc == 3) { + Tcl_Size size; + + Tcl_DictObjSize(interp, value->dictPtr, &size); + resultPtr = Tcl_NewIntObj(size != 0); + } else { + Tcl_Obj *testObj; + + Tcl_DictObjGet(NULL, value->dictPtr, objv[3], &testObj); + resultPtr = Tcl_NewIntObj(testObj != NULL); + } + } + } + + Tcl_SetObjResult(interp, resultPtr); + break; + } + + case TABLE_NAMES: { + Tcl_Obj *resultPtr; + Tcl_DictSearch search; + Tcl_Obj *key; + int done; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "pathName"); + return TCL_ERROR; + } + + entryPtr = Tcl_FindHashEntry(tblData->tablePtr, tkwin); + if (entryPtr == NULL) { + return TCL_OK; + } + + resultPtr = Tcl_NewObj(); + value = Tcl_GetHashValue(entryPtr); + Tcl_DictObjFirst(interp, value->dictPtr, &search, &key, NULL, &done); + while (!done) { + Tcl_ListObjAppendElement(NULL, resultPtr, key); + Tcl_DictObjNext(&search, &key, NULL, &done); + } + Tcl_DictObjDone(&search); + + Tcl_SetObjResult(interp, resultPtr); + break; + } + + case TABLE_PATHNAMES: { + Tcl_Obj *resultPtr; + Tcl_HashSearch search; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } + + resultPtr = Tcl_NewObj(); + for (entryPtr = Tcl_FirstHashEntry(tblData->tablePtr, &search); + entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&search)) { + Tcl_Size size; + + value = Tcl_GetHashValue(entryPtr); + Tcl_DictObjSize(interp, value->dictPtr, &size); + if (size != 0) { + Tcl_ListObjAppendElement(NULL, resultPtr, + Tcl_NewStringObj(Tk_PathName(value->tkwin), -1)); + } + } + + Tcl_SetObjResult(interp, resultPtr); + break; + } + } /* switch */ + + return TCL_OK; +} + +/* + * Called before the attribute table command is deleted from the interpreter. + */ + +void +AttribTableDeleteProc( + void *clientData) /* Pointer to an AttribTableData struct. */ +{ + AttribTableData *tblData = (AttribTableData *)clientData; + Tcl_HashEntry *entryPtr; + Tcl_HashSearch search; + + for (entryPtr = Tcl_FirstHashEntry(tblData->tablePtr, &search); + entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&search)) { + AttribTableValue *value = Tcl_GetHashValue(entryPtr); + + /* + * Delete the event handler associated with value->tkwin. + */ + + Tk_DeleteEventHandler(value->tkwin, StructureNotifyMask, + AttribTableDestroyHandler, value); + + /* + * Remove the entry from the hash table. + */ + + Tcl_DecrRefCount(value->dictPtr); + Tcl_DeleteHashEntry(entryPtr); + ckfree(value); + } + + /* + * Free up the memory used by the hash table. + */ + + Tcl_DeleteHashTable(tblData->tablePtr); + ckfree(tblData->tablePtr); + ckfree(tblData); +} + +/* + * Called when the window identified by the first argument gets destroyed. + */ + +void +AttribTableDestroyHandler( + void *clientData, /* Pointer to an AttribTableValue struct. */ + XEvent *eventPtr) /* Information about event. */ +{ + AttribTableValue *value = (AttribTableValue *)clientData; + Tcl_HashEntry *entryPtr; + + if (eventPtr->type != DestroyNotify) { + return; + } + + entryPtr = Tcl_FindHashEntry(value->tablePtr, value->tkwin); + if (entryPtr == NULL) { + return; + } + + /* + * Remove the entry from the hash table. + */ + + Tcl_DecrRefCount(value->dictPtr); + Tcl_DeleteHashEntry(entryPtr); + ckfree(value); +} + int CaretCmd( void *clientData, /* Main window associated with interpreter. */ @@ -804,6 +1226,52 @@ CaretCmd( } int +InactiveCmd( + void *clientData, /* Main window associated with interpreter. */ + Tcl_Interp *interp, /* Current interpreter. */ + Tcl_Size objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tk_Window tkwin = (Tk_Window)clientData; + Tcl_Size skip = TkGetDisplayOf(interp, objc - 1, objv + 1, &tkwin); + + if (skip < 0) { + return TCL_ERROR; + } + if (objc == 1 + skip) { + Tcl_WideInt inactive; + + inactive = (Tcl_IsSafe(interp) ? -1 : + Tk_GetUserInactiveTime(Tk_Display(tkwin))); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(inactive)); + } else if (objc == 2 + skip) { + const char *string; + + string = Tcl_GetString(objv[objc-1]); + if (strcmp(string, "reset") != 0) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad option \"%s\": must be reset", string)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", + string, (char *)NULL); + return TCL_ERROR; + } + if (Tcl_IsSafe(interp)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "resetting the user inactivity timer " + "is not allowed in a safe interpreter", TCL_INDEX_NONE)); + Tcl_SetErrorCode(interp, "TK", "SAFE", "INACTIVITY_TIMER", (char *)NULL); + return TCL_ERROR; + } + Tk_ResetUserInactiveTime(Tk_Display(tkwin)); + Tcl_ResetResult(interp); + } else { + Tcl_WrongNumArgs(interp, 1, objv, "?-displayof window? ?reset?"); + return TCL_ERROR; + } + return TCL_OK; +} + +int ScalingCmd( void *clientData, /* Main window associated with interpreter. */ Tcl_Interp *interp, /* Current interpreter. */ @@ -945,52 +1413,6 @@ WindowingsystemCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj(windowingsystem, TCL_INDEX_NONE)); return TCL_OK; } - -int -InactiveCmd( - void *clientData, /* Main window associated with interpreter. */ - Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Size objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tk_Window tkwin = (Tk_Window)clientData; - Tcl_Size skip = TkGetDisplayOf(interp, objc - 1, objv + 1, &tkwin); - - if (skip < 0) { - return TCL_ERROR; - } - if (objc == 1 + skip) { - Tcl_WideInt inactive; - - inactive = (Tcl_IsSafe(interp) ? -1 : - Tk_GetUserInactiveTime(Tk_Display(tkwin))); - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(inactive)); - } else if (objc == 2 + skip) { - const char *string; - - string = Tcl_GetString(objv[objc-1]); - if (strcmp(string, "reset") != 0) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad option \"%s\": must be reset", string)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", - string, (char *)NULL); - return TCL_ERROR; - } - if (Tcl_IsSafe(interp)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "resetting the user inactivity timer " - "is not allowed in a safe interpreter", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "SAFE", "INACTIVITY_TIMER", (char *)NULL); - return TCL_ERROR; - } - Tk_ResetUserInactiveTime(Tk_Display(tkwin)); - Tcl_ResetResult(interp); - } else { - Tcl_WrongNumArgs(interp, 1, objv, "?-displayof window? ?reset?"); - return TCL_ERROR; - } - return TCL_OK; -} /* *---------------------------------------------------------------------- diff --git a/generic/tkColor.c b/generic/tkColor.c index feaf93c..37df563 100644 --- a/generic/tkColor.c +++ b/generic/tkColor.c @@ -232,11 +232,11 @@ Tk_GetColor( if (*name == '#') { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid color name \"%s\"", name)); - Tcl_SetErrorCode(interp, "TK", "VALUE", "COLOR", NULL); + Tcl_SetErrorCode(interp, "TK", "VALUE", "COLOR", (char *)NULL); } else { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown color name \"%s\"", name)); - Tcl_SetErrorCode(interp, "TK", "LOOKUP", "COLOR", name, NULL); + Tcl_SetErrorCode(interp, "TK", "LOOKUP", "COLOR", name, (char *)NULL); } } if (isNew) { diff --git a/generic/tkColor.h b/generic/tkColor.h index d4a1fa7..ffc6f89 100644 --- a/generic/tkColor.h +++ b/generic/tkColor.h @@ -69,7 +69,7 @@ typedef struct TkColor { #ifndef TkpFreeColor MODULE_SCOPE void TkpFreeColor(TkColor *tkColPtr); #endif -MODULE_SCOPE TkColor * TkpGetColor(Tk_Window tkwin, Tk_Uid name); +MODULE_SCOPE TkColor * TkpGetColor(Tk_Window tkwin, const char *name); MODULE_SCOPE TkColor * TkpGetColorByValue(Tk_Window tkwin, XColor *colorPtr); #endif /* _TKCOLOR */ diff --git a/generic/tkConfig.c b/generic/tkConfig.c index 8dec92c..b0d6025 100644 --- a/generic/tkConfig.c +++ b/generic/tkConfig.c @@ -1113,15 +1113,15 @@ DoObjConfig( #if defined(USE_TCL_STUBS) # undef Tcl_IsEmpty # define Tcl_IsEmpty \ - ((int (*)(Tcl_Obj *))(void *)((&(tclStubsPtr->tcl_PkgProvideEx))[690])) + ((bool (*)(Tcl_Obj *))(void *)((&(tclStubsPtr->tcl_PkgProvideEx))[690])) #endif -int +bool TkObjIsEmpty( Tcl_Obj *objPtr) /* Object to test. May be NULL. */ { if (objPtr == NULL) { - return 1; + return true; } if (objPtr->bytes == NULL) { #if defined(USE_TCL_STUBS) diff --git a/generic/tkConsole.c b/generic/tkConsole.c index 6768dac..4e268d3 100644 --- a/generic/tkConsole.c +++ b/generic/tkConsole.c @@ -759,7 +759,7 @@ ConsoleObjCmd( } else { Tcl_SetObjResult(interp, Tcl_NewStringObj( "no active console interp", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "CONSOLE", "NONE", NULL); + Tcl_SetErrorCode(interp, "TK", "CONSOLE", "NONE", (char *)NULL); result = TCL_ERROR; } Tcl_DecrRefCount(cmd); @@ -810,7 +810,7 @@ InterpreterObjCmd( if ((otherInterp == NULL) || Tcl_InterpDeleted(otherInterp)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "no active parent interp", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "CONSOLE", "NO_INTERP", NULL); + Tcl_SetErrorCode(interp, "TK", "CONSOLE", "NO_INTERP", (char *)NULL); return TCL_ERROR; } diff --git a/generic/tkCursor.c b/generic/tkCursor.c index f2d3af0..d402961 100644 --- a/generic/tkCursor.c +++ b/generic/tkCursor.c @@ -360,13 +360,13 @@ Tk_GetCursorFromData( if (TkParseColor(dataKey.display, Tk_Colormap(tkwin), fg, &fgColor) == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid color name \"%s\"", fg)); - Tcl_SetErrorCode(interp, "TK", "VALUE", "CURSOR", "COLOR", NULL); + Tcl_SetErrorCode(interp, "TK", "VALUE", "CURSOR", "COLOR", (char *)NULL); goto error; } if (TkParseColor(dataKey.display, Tk_Colormap(tkwin), bg, &bgColor) == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid color name \"%s\"", bg)); - Tcl_SetErrorCode(interp, "TK", "VALUE", "CURSOR", "COLOR", NULL); + Tcl_SetErrorCode(interp, "TK", "VALUE", "CURSOR", "COLOR", (char *)NULL); goto error; } diff --git a/generic/tkFileFilter.c b/generic/tkFileFilter.c index cac1c78..7ceeadb 100644 --- a/generic/tkFileFilter.c +++ b/generic/tkFileFilter.c @@ -124,7 +124,7 @@ TkGetFileFilters( "\"typeName {extension ?extensions ...?} " "?{macType ?macTypes ...?}?\"", Tcl_GetString(listObjv[i]))); - Tcl_SetErrorCode(interp, "TK", "VALUE", "FILE_TYPE", NULL); + Tcl_SetErrorCode(interp, "TK", "VALUE", "FILE_TYPE", (char *)NULL); return TCL_ERROR; } @@ -294,7 +294,7 @@ AddClause( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad Macintosh file type \"%s\"", Tcl_GetString(ostypeList[i]))); - Tcl_SetErrorCode(interp, "TK", "VALUE", "MAC_TYPE", NULL); + Tcl_SetErrorCode(interp, "TK", "VALUE", "MAC_TYPE", (char *)NULL); code = TCL_ERROR; goto done; } diff --git a/generic/tkFont.c b/generic/tkFont.c index cc1beb8..02ccb3a 100644 --- a/generic/tkFont.c +++ b/generic/tkFont.c @@ -585,7 +585,7 @@ Tk_FontObjCmd( TCL_INDEX_NONE, 40, "..."); Tcl_AppendToObj(resultPtr, "\"", TCL_INDEX_NONE); Tcl_SetObjResult(interp, resultPtr); - Tcl_SetErrorCode(interp, "TK", "VALUE", "FONT_SAMPLE", NULL); + Tcl_SetErrorCode(interp, "TK", "VALUE", "FONT_SAMPLE", (char *)NULL); return TCL_ERROR; } } @@ -634,7 +634,7 @@ Tk_FontObjCmd( if ((namedHashPtr == NULL) || nfPtr->deletePending) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "named font \"%s\" does not exist", string)); - Tcl_SetErrorCode(interp, "TK", "LOOKUP", "FONT", string, NULL); + Tcl_SetErrorCode(interp, "TK", "LOOKUP", "FONT", string, (char *)NULL); return TCL_ERROR; } if (objc == 3) { @@ -977,7 +977,7 @@ TkCreateNamedFont( if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "named font \"%s\" already exists", name)); - Tcl_SetErrorCode(interp, "TK", "FONT", "EXISTS", NULL); + Tcl_SetErrorCode(interp, "TK", "FONT", "EXISTS", (char *)NULL); } return TCL_ERROR; } @@ -1029,7 +1029,7 @@ TkDeleteNamedFont( if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "named font \"%s\" does not exist", name)); - Tcl_SetErrorCode(interp, "TK", "LOOKUP", "FONT", name, NULL); + Tcl_SetErrorCode(interp, "TK", "LOOKUP", "FONT", name, (char *)NULL); } return TCL_ERROR; } @@ -1216,7 +1216,7 @@ Tk_AllocFontFromObj( Tcl_SetObjResult(interp, Tcl_NewStringObj( "failed to allocate font due to internal system font engine" " problem", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "FONT", "INTERNAL_PROBLEM", NULL); + Tcl_SetErrorCode(interp, "TK", "FONT", "INTERNAL_PROBLEM", (char *)NULL); return NULL; } @@ -3443,7 +3443,7 @@ ConfigAttributesObj( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "value for \"%s\" option missing", Tcl_GetString(optionPtr))); - Tcl_SetErrorCode(interp, "TK", "FONT", "NO_ATTRIBUTE", NULL); + Tcl_SetErrorCode(interp, "TK", "FONT", "NO_ATTRIBUTE", (char *)NULL); } return TCL_ERROR; } @@ -3744,7 +3744,7 @@ ParseFontNameObj( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "font \"%s\" does not exist", string)); - Tcl_SetErrorCode(interp, "TK", "LOOKUP", "FONT", string, NULL); + Tcl_SetErrorCode(interp, "TK", "LOOKUP", "FONT", string, (char *)NULL); } return TCL_ERROR; } diff --git a/generic/tkFrame.c b/generic/tkFrame.c index 3da7069..dc04ddc 100644 --- a/generic/tkFrame.c +++ b/generic/tkFrame.c @@ -537,7 +537,7 @@ TkCreateFrame( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unable to create widget \"%s\"", Tcl_GetString(objv[1]))); - Tcl_SetErrorCode(interp, "TK", "APPLICATION_GONE", NULL); + Tcl_SetErrorCode(interp, "TK", "APPLICATION_GONE", (char *)NULL); return TCL_ERROR; } else { /* @@ -657,7 +657,7 @@ TkCreateFrame( Tcl_SetObjResult(interp, Tcl_NewStringObj( "windows cannot have both the -use and the -container" " option set", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "FRAME", "CONTAINMENT", NULL); + Tcl_SetErrorCode(interp, "TK", "FRAME", "CONTAINMENT", (char *)NULL); goto error; } Tk_MakeContainer(framePtr->tkwin); @@ -1044,7 +1044,7 @@ ConfigureFrame( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't use %s as label in this frame", Tk_PathName(labelframePtr->labelWin))); - Tcl_SetErrorCode(interp, "TK", "GEOMETRY", "HIERARCHY", NULL); + Tcl_SetErrorCode(interp, "TK", "GEOMETRY", "HIERARCHY", (char *)NULL); labelframePtr->labelWin = NULL; return TCL_ERROR; } diff --git a/generic/tkImgGIF.c b/generic/tkImgGIF.c index 0a842fd..c07d986 100644 --- a/generic/tkImgGIF.c +++ b/generic/tkImgGIF.c @@ -935,7 +935,7 @@ ReadOneByte( Tcl_SetObjResult(interp, Tcl_NewStringObj( "premature end of image data", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "GIF", "PREMATURE_END", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "GIF", "PREMATURE_END", (char *)NULL); return -1; } return buf[0]; diff --git a/generic/tkImgPNG.c b/generic/tkImgPNG.c index a49ed15..50861bc 100644 --- a/generic/tkImgPNG.c +++ b/generic/tkImgPNG.c @@ -355,7 +355,7 @@ InitPNGImage( if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "zlib initialization failed", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "ZLIB_INIT", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "ZLIB_INIT", (char *)NULL); } if (objPtr) { Tcl_DecrRefCount(objPtr); @@ -546,7 +546,7 @@ ReadBase64( if (destSz) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "unexpected end of image data", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "EARLY_END", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "EARLY_END", (char *)NULL); return TCL_ERROR; } @@ -590,7 +590,7 @@ ReadByteArray( if (pngPtr->strDataLen < destSz) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "unexpected end of image data", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "EARLY_END", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "EARLY_END", (char *)NULL); return TCL_ERROR; } @@ -678,7 +678,7 @@ ReadData( if (destSz && Tcl_Eof(pngPtr->channel)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "unexpected end of file", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "EOF", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "EOF", (char *)NULL); return TCL_ERROR; } } @@ -764,7 +764,7 @@ CheckCRC( if (calculated != chunked) { Tcl_SetObjResult(interp, Tcl_NewStringObj("CRC check failed", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "CRC", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "CRC", (char *)NULL); return TCL_ERROR; } @@ -917,7 +917,7 @@ ReadChunkHeader( Tcl_SetObjResult(interp, Tcl_NewStringObj( "chunk size is out of supported range on this architecture", -1)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "OUTSIZE", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "OUTSIZE", (char *)NULL); return TCL_ERROR; } @@ -1137,7 +1137,7 @@ CheckColor( unsupportedDepth: Tcl_SetObjResult(interp, Tcl_NewStringObj( "bit depth is not allowed for given color type", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "BAD_DEPTH", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "BAD_DEPTH", (char *)NULL); return TCL_ERROR; } break; @@ -1145,7 +1145,7 @@ CheckColor( default: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown color type field %d", pngPtr->colorType)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "UNKNOWN_COLOR", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "UNKNOWN_COLOR", (char *)NULL); return TCL_ERROR; } @@ -1176,7 +1176,7 @@ CheckColor( Tcl_SetObjResult(interp, Tcl_NewStringObj( "image pitch is out of supported range on this architecture", -1)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "PITCH", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "PITCH", (char *)NULL); return TCL_ERROR; } @@ -1191,7 +1191,7 @@ CheckColor( Tcl_SetObjResult(interp, Tcl_NewStringObj( "image total size is out of supported range on this architecture", -1)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "SIZE", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "SIZE", (char *)NULL); return TCL_ERROR; } @@ -1220,7 +1220,7 @@ CheckColor( default: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown color type %d", pngPtr->colorType)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "UNKNOWN_COLOR", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "UNKNOWN_COLOR", (char *)NULL); return TCL_ERROR; } @@ -1302,7 +1302,7 @@ ReadIHDR( if (mismatch) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "data stream does not have a PNG signature", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "NO_SIG", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "NO_SIG", (char *)NULL); return TCL_ERROR; } @@ -1320,14 +1320,14 @@ ReadIHDR( if (chunkType != CHUNK_IHDR) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "expected IHDR chunk type", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "NO_IHDR", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "NO_IHDR", (char *)NULL); return TCL_ERROR; } if (chunkSz != 13) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "invalid IHDR chunk size", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "BAD_IHDR", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "BAD_IHDR", (char *)NULL); return TCL_ERROR; } @@ -1349,7 +1349,7 @@ ReadIHDR( Tcl_SetObjResult(interp, Tcl_NewStringObj( "image dimensions are invalid or beyond architecture limits", -1)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "DIMENSIONS", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "DIMENSIONS", (char *)NULL); return TCL_ERROR; } @@ -1394,7 +1394,7 @@ ReadIHDR( if (pngPtr->compression != PNG_COMPRESS_DEFLATE) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown compression method %d", pngPtr->compression)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "BAD_COMPRESS", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "BAD_COMPRESS", (char *)NULL); return TCL_ERROR; } @@ -1410,7 +1410,7 @@ ReadIHDR( if (pngPtr->filter != PNG_FILTMETH_STANDARD) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown filter method %d", pngPtr->filter)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "BAD_FILTER", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "BAD_FILTER", (char *)NULL); return TCL_ERROR; } @@ -1426,7 +1426,7 @@ ReadIHDR( default: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown interlace method %d", pngPtr->interlace)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "BAD_INTERLACE", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "BAD_INTERLACE", (char *)NULL); return TCL_ERROR; } @@ -1472,7 +1472,7 @@ ReadPLTE( Tcl_SetObjResult(interp, Tcl_NewStringObj( "PLTE chunk type forbidden for grayscale", TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "PLTE_UNEXPECTED", - NULL); + (char *)NULL); return TCL_ERROR; default: @@ -1488,7 +1488,7 @@ ReadPLTE( if (!chunkSz || (chunkSz > PNG_PLTE_MAXSZ) || (chunkSz % 3)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "invalid palette chunk size", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "BAD_PLTE", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "BAD_PLTE", (char *)NULL); return TCL_ERROR; } @@ -1553,7 +1553,7 @@ ReadTRNS( Tcl_SetObjResult(interp, Tcl_NewStringObj( "tRNS chunk not allowed color types with a full alpha channel", -1)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "INVALID_TRNS", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "INVALID_TRNS", (char *)NULL); return TCL_ERROR; } @@ -1565,7 +1565,7 @@ ReadTRNS( if (chunkSz > PNG_TRNS_MAXSZ) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "invalid tRNS chunk size", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "BAD_TRNS", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "BAD_TRNS", (char *)NULL); return TCL_ERROR; } @@ -1596,7 +1596,7 @@ ReadTRNS( if (chunkSz > pngPtr->paletteLen) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "size of tRNS chunk is too large for the palette", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "TRNS_SIZE", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "TRNS_SIZE", (char *)NULL); return TCL_ERROR; } @@ -1615,7 +1615,7 @@ ReadTRNS( Tcl_SetObjResult(interp, Tcl_NewStringObj( "invalid tRNS chunk size - must 2 bytes for grayscale", -1)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "BAD_TRNS", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "BAD_TRNS", (char *)NULL); return TCL_ERROR; } @@ -1641,7 +1641,7 @@ ReadTRNS( if (chunkSz != 6) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "invalid tRNS chunk size - must 6 bytes for RGB", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "BAD_TRNS", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "BAD_TRNS", (char *)NULL); return TCL_ERROR; } @@ -1701,7 +1701,7 @@ ReadPHYS( if (chunkSz != 9) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "invalid physical chunk size", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "BAD_PHYS", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "BAD_PHYS", (char *)NULL); return TCL_ERROR; } @@ -1730,7 +1730,7 @@ ReadPHYS( || unitSpecifier > 1 ) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "invalid physical size value", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "BAD_PHYS", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "BAD_PHYS", (char *)NULL); return TCL_ERROR; } @@ -1902,7 +1902,7 @@ UnfilterLine( default: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid filter type %d", *thisLine)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "BAD_FILTER", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "BAD_FILTER", (char *)NULL); return TCL_ERROR; } @@ -1952,7 +1952,7 @@ DecodeLine( if (pngPtr->currentLine >= pngPtr->block.height) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "PNG image data overflow")); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "DATA_OVERFLOW", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "DATA_OVERFLOW", (char *)NULL); return TCL_ERROR; } @@ -2310,7 +2310,7 @@ ReadIDAT( if (chunkSz != 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "compressed data after stream finalize in PNG data", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "EXTRA_DATA", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "EXTRA_DATA", (char *)NULL); return TCL_ERROR; } @@ -2566,7 +2566,7 @@ DecodePNG( } else if (PNG_COLOR_PLTE == pngPtr->colorType) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "PLTE chunk required for indexed color", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "NEED_PLTE", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "NEED_PLTE", (char *)NULL); return TCL_ERROR; } @@ -2627,7 +2627,7 @@ DecodePNG( if (chunkType != CHUNK_IDAT) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "at least one IDAT chunk is required", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "NEED_IDAT", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "NEED_IDAT", (char *)NULL); return TCL_ERROR; } @@ -2651,7 +2651,7 @@ DecodePNG( Tcl_SetObjResult(interp, Tcl_NewStringObj( "line size is out of supported range on this architecture", -1)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "LINE_SIZE", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "LINE_SIZE", (char *)NULL); return TCL_ERROR; } @@ -2678,7 +2678,7 @@ DecodePNG( if (!pngPtr->block.pixelPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "memory allocation failed", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "MALLOC", NULL); + Tcl_SetErrorCode(interp, "TK", "MALLOC", (char *)NULL); return TCL_ERROR; } @@ -2730,7 +2730,7 @@ DecodePNG( if (!Tcl_ZlibStreamEof(pngPtr->stream)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "unfinalized data stream in PNG data", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "EXTRA_DATA", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "EXTRA_DATA", (char *)NULL); return TCL_ERROR; } @@ -2756,7 +2756,7 @@ DecodePNG( if (chunkSz) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "IEND chunk contents must be empty", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "BAD_IEND", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "BAD_IEND", (char *)NULL); return TCL_ERROR; } @@ -2777,7 +2777,7 @@ DecodePNG( if (ReadData(interp, pngPtr, &c, 1, NULL) != TCL_ERROR) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "extra data following IEND chunk", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "BAD_IEND", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "BAD_IEND", (char *)NULL); return TCL_ERROR; } #endif @@ -3056,7 +3056,7 @@ WriteData( if (objSz + srcSz > INT_MAX) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "image too large to store completely in byte array", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "TOO_LARGE", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "TOO_LARGE", (char *)NULL); return TCL_ERROR; } @@ -3065,7 +3065,7 @@ WriteData( if (!destPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "memory allocation failed", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "MALLOC", NULL); + Tcl_SetErrorCode(interp, "TK", "MALLOC", (char *)NULL); return TCL_ERROR; } @@ -3413,7 +3413,7 @@ WriteIDAT( flush) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "deflate() returned error", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "DEFLATE", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "DEFLATE", (char *)NULL); return TCL_ERROR; } @@ -3574,7 +3574,7 @@ WriteExtraChunks( if ( PPUx > 2147483647 || PPUy > 2147483647 ) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "DPI or aspect out of range", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "PHYS", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "PHYS", (char *)NULL); return TCL_ERROR; } @@ -3664,7 +3664,7 @@ EncodePNG( (blockPtr->height > INT_MAX / pngPtr->lineSize)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "image is too large to encode pixel data", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "TOO_LARGE", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "TOO_LARGE", (char *)NULL); return TCL_ERROR; } diff --git a/generic/tkImgPPM.c b/generic/tkImgPPM.c index a9d0391..f3f7c60 100644 --- a/generic/tkImgPPM.c +++ b/generic/tkImgPPM.c @@ -154,20 +154,20 @@ FileReadPPM( if (type == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read raw PPM header from file \"%s\"", fileName)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PPM", "NO_HEADER", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PPM", "NO_HEADER", (char *)NULL); return TCL_ERROR; } if ((fileWidth <= 0) || (fileHeight <= 0)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "PPM image file \"%s\" has dimension(s) <= 0", fileName)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PPM", "DIMENSIONS", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PPM", "DIMENSIONS", (char *)NULL); return TCL_ERROR; } if ((maxIntensity <= 0) || (maxIntensity > 0xffff)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "PPM image file \"%s\" has bad maximum intensity value %d", fileName, maxIntensity)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PPM", "INTENSITY", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PPM", "INTENSITY", (char *)NULL); return TCL_ERROR; } else if (maxIntensity > 0x00ff) { bytesPerChannel = 2; @@ -230,7 +230,7 @@ FileReadPPM( "error reading PPM image file \"%s\": %s", fileName, Tcl_Eof(chan)?"not enough data":Tcl_PosixError(interp))); if (Tcl_Eof(chan)) { - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PPM", "EOF", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PPM", "EOF", (char *)NULL); } ckfree(pixelPtr); return TCL_ERROR; @@ -499,20 +499,20 @@ StringReadPPM( if (type == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "couldn't read raw PPM header from string", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PPM", "NO_HEADER", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PPM", "NO_HEADER", (char *)NULL); return TCL_ERROR; } if ((fileWidth <= 0) || (fileHeight <= 0)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "PPM image data has dimension(s) <= 0", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PPM", "DIMENSIONS", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PPM", "DIMENSIONS", (char *)NULL); return TCL_ERROR; } if ((maxIntensity <= 0) || (maxIntensity > 0xffff)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "PPM image data has bad maximum intensity value %d", maxIntensity)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PPM", "INTENSITY", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PPM", "INTENSITY", (char *)NULL); return TCL_ERROR; } else if (maxIntensity > 0x00ff) { bytesPerChannel = 2; @@ -557,7 +557,7 @@ StringReadPPM( if (block.pitch*height > dataSize) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "truncated PPM data", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PPM", "TRUNCATED", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PPM", "TRUNCATED", (char *)NULL); return TCL_ERROR; } block.pixelPtr = dataBuffer + srcX * block.pixelSize; @@ -593,7 +593,7 @@ StringReadPPM( ckfree(pixelPtr); Tcl_SetObjResult(interp, Tcl_NewStringObj( "truncated PPM data", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "PPM", "TRUNCATED", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "PPM", "TRUNCATED", (char *)NULL); return TCL_ERROR; } if (maxIntensity < 0x00ff) { diff --git a/generic/tkImgPhoto.c b/generic/tkImgPhoto.c index 1dbadf6..fcb1c1c 100644 --- a/generic/tkImgPhoto.c +++ b/generic/tkImgPhoto.c @@ -4143,6 +4143,9 @@ ImgGetPhoto( int x, y, greenOffset, blueOffset, alphaOffset; Tk_PhotoGetImage((Tk_PhotoHandle) modelPtr, blockPtr); + if (!blockPtr->pixelPtr) { + return NULL; + } blockPtr->pixelPtr += optPtr->fromY * blockPtr->pitch + optPtr->fromX * blockPtr->pixelSize; blockPtr->width = optPtr->fromX2 - optPtr->fromX; diff --git a/generic/tkImgSVGnano.c b/generic/tkImgSVGnano.c index 29b0e0e..4c46f86 100644 --- a/generic/tkImgSVGnano.c +++ b/generic/tkImgSVGnano.c @@ -249,7 +249,7 @@ FileReadSVG( /* in case of an error reading the file */ Tcl_DecrRefCount(dataObj); Tcl_SetObjResult(interp, Tcl_NewStringObj("read error", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "SVG", "READ_ERROR", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "SVG", "READ_ERROR", (char *)NULL); return TCL_ERROR; } data = Tcl_GetStringFromObj(dataObj, &length); @@ -406,7 +406,7 @@ ParseSVGWithOptions( inputCopy = (char *)attemptckalloc(length+1); if (inputCopy == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("cannot alloc data buffer", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "SVG", "OUT_OF_MEMORY", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "SVG", "OUT_OF_MEMORY", (char *)NULL); goto error; } memcpy(inputCopy, input, length); @@ -530,7 +530,7 @@ ParseSVGWithOptions( nsvgImage = nsvgParse(inputCopy, "px", (float) dpi); if (nsvgImage == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("cannot parse SVG image", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "SVG", "PARSE_ERROR", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "SVG", "PARSE_ERROR", (char *)NULL); goto error; } ckfree(inputCopy); @@ -594,14 +594,14 @@ RasterizeSVG( wh = (Tcl_WideUInt)w * (Tcl_WideUInt)h; if ( w < 0 || h < 0 || wh > INT_MAX / 4) { Tcl_SetObjResult(interp, Tcl_NewStringObj("image size overflow", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "SVG", "IMAGE_SIZE_OVERFLOW", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "SVG", "IMAGE_SIZE_OVERFLOW", (char *)NULL); goto cleanRAST; } imgData = (unsigned char *)attemptckalloc(wh * 4); if (imgData == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("cannot alloc image buffer", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "SVG", "OUT_OF_MEMORY", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "SVG", "OUT_OF_MEMORY", (char *)NULL); goto cleanRAST; } nsvgRasterize(rast, nsvgImage, 0, 0, diff --git a/generic/tkInt.decls b/generic/tkInt.decls index c6b61e0..a2baa7f 100644 --- a/generic/tkInt.decls +++ b/generic/tkInt.decls @@ -212,7 +212,7 @@ declare 54 { double width, int filled, double pointPtr[]) } declare 55 { - int TkpChangeFocus(TkWindow *winPtr, int force) + size_t TkpChangeFocus(TkWindow *winPtr, int force) } declare 56 { void TkpCloseDisplay(TkDisplay *dispPtr) @@ -718,7 +718,7 @@ declare 16 win { HDC TkWinGetDrawableDC(Display *display, Drawable d, TkWinDCState *state) } declare 17 win { - int TkWinGetModifierState(void) + unsigned int TkWinGetModifierState(void) } declare 18 win { HPALETTE TkWinGetSystemPalette(void) @@ -779,9 +779,11 @@ declare 33 win { declare 34 win { void TkWinSetHINSTANCE(HINSTANCE hInstance) } -declare 35 win { - int TkWinGetPlatformTheme(void) -} + +# removed in Tk 9.1 +#declare 35 win { +# int TkWinGetPlatformTheme(void) +#} # Exported through stub table since Tk 8.4.20/8.5.9 @@ -915,7 +917,7 @@ declare 38 aqua { int TkSetMacColor(unsigned long pixel, void *macColor) } declare 39 aqua { - void TkSetWMName(TkWindow *winPtr, Tk_Uid titleUid) + void TkSetWMName(TkWindow *winPtr, const char *title) } declare 41 aqua { int TkMacOSXZoomToplevel(void *whichWindow, short zoomPart) @@ -1427,6 +1429,12 @@ declare 142 win { declare 143 win { void XSetICFocus(XIC xic) } +declare 144 win { + int XXorRegion(Region sra, Region srb, Region dr_return) +} +declare 145 win { + Bool XEqualRegion(Region r1, Region r2) +} declare 147 win { void XFreeFontSet(Display *display, XFontSet fontset) } @@ -1933,6 +1941,12 @@ declare 142 macosx { declare 143 macosx { void XSetICFocus(XIC xic) } +declare 144 macosx { + int XXorRegion(Region sra, Region srb, Region dr_return) +} +declare 145 macosx { + Bool XEqualRegion(Region r1, Region r2) +} declare 147 macosx { void XFreeFontSet(Display *display, XFontSet fontset) } diff --git a/generic/tkInt.h b/generic/tkInt.h index 50ddff6..4b879af 100644 --- a/generic/tkInt.h +++ b/generic/tkInt.h @@ -33,6 +33,9 @@ #endif #include <stdint.h> #include <stdlib.h> +#if defined(_MSC_VER) || (defined(__STDC_VERSION__) && (__STDC_VERSION__ < 202311L)) +#include <stdbool.h> +#endif #ifdef BYTE_ORDER # ifdef BIG_ENDIAN # if BYTE_ORDER == BIG_ENDIAN @@ -1112,7 +1115,7 @@ void Tcl_Panic(const char *, ...) __attribute__((analyzer_noreturn)); * Exported internals. */ -#include "tkIntDecls.h" +#include "tkIntDecls.h" /* IWYU pragma: export */ #ifdef __cplusplus extern "C" { @@ -1236,7 +1239,7 @@ MODULE_SCOPE Tcl_Command TkMakeEnsemble(Tcl_Interp *interp, const char *nsname, const char *name, void *clientData, const TkEnsemble *map); MODULE_SCOPE double TkScalingLevel(Tk_Window tkwin); -MODULE_SCOPE int TkObjIsEmpty(Tcl_Obj *objPtr); +MODULE_SCOPE bool TkObjIsEmpty(Tcl_Obj *objPtr); MODULE_SCOPE int TkInitTkCmd(Tcl_Interp *interp, void *clientData); MODULE_SCOPE int TkInitFontchooser(Tcl_Interp *interp, diff --git a/generic/tkIntDecls.h b/generic/tkIntDecls.h index bd4912f..f657af2 100644 --- a/generic/tkIntDecls.h +++ b/generic/tkIntDecls.h @@ -193,7 +193,7 @@ EXTERN int TkOvalToArea(double *ovalPtr, double *rectPtr); EXTERN double TkOvalToPoint(double ovalPtr[], double width, int filled, double pointPtr[]); /* 55 */ -EXTERN int TkpChangeFocus(TkWindow *winPtr, int force); +EXTERN size_t TkpChangeFocus(TkWindow *winPtr, int force); /* 56 */ EXTERN void TkpCloseDisplay(TkDisplay *dispPtr); /* 57 */ @@ -605,7 +605,7 @@ typedef struct TkIntStubs { void (*tkOptionDeadWindow) (TkWindow *winPtr); /* 52 */ int (*tkOvalToArea) (double *ovalPtr, double *rectPtr); /* 53 */ double (*tkOvalToPoint) (double ovalPtr[], double width, int filled, double pointPtr[]); /* 54 */ - int (*tkpChangeFocus) (TkWindow *winPtr, int force); /* 55 */ + size_t (*tkpChangeFocus) (TkWindow *winPtr, int force); /* 55 */ void (*tkpCloseDisplay) (TkDisplay *dispPtr); /* 56 */ void (*tkpClaimFocus) (TkWindow *topLevelPtr, int force); /* 57 */ void (*tkpDisplayWarning) (const char *msg, const char *title); /* 58 */ diff --git a/generic/tkIntPlatDecls.h b/generic/tkIntPlatDecls.h index 7d55a30..5142caa 100644 --- a/generic/tkIntPlatDecls.h +++ b/generic/tkIntPlatDecls.h @@ -75,7 +75,7 @@ EXTERN COLORREF TkWinGetBorderPixels(Tk_Window tkwin, EXTERN HDC TkWinGetDrawableDC(Display *display, Drawable d, TkWinDCState *state); /* 17 */ -EXTERN int TkWinGetModifierState(void); +EXTERN unsigned int TkWinGetModifierState(void); /* 18 */ EXTERN HPALETTE TkWinGetSystemPalette(void); /* 19 */ @@ -117,8 +117,7 @@ EXTERN char * TkAlignImageData(XImage *image, int alignment, int bitOrder); /* 34 */ EXTERN void TkWinSetHINSTANCE(HINSTANCE hInstance); -/* 35 */ -EXTERN int TkWinGetPlatformTheme(void); +/* Slot 35 is reserved */ /* 36 */ EXTERN LRESULT __stdcall TkWinChildProc(HWND hwnd, UINT message, WPARAM wParam, LPARAM lParam); @@ -220,7 +219,7 @@ EXTERN void TkMacOSXWindowOffset(void *wRef, int *xOffset, /* 38 */ EXTERN int TkSetMacColor(unsigned long pixel, void *macColor); /* 39 */ -EXTERN void TkSetWMName(TkWindow *winPtr, Tk_Uid titleUid); +EXTERN void TkSetWMName(TkWindow *winPtr, const char *title); /* Slot 40 is reserved */ /* 41 */ EXTERN int TkMacOSXZoomToplevel(void *whichWindow, @@ -333,7 +332,7 @@ typedef struct TkIntPlatStubs { void (*tkWinFillRect) (HDC dc, int x, int y, int width, int height, int pixel); /* 14 */ COLORREF (*tkWinGetBorderPixels) (Tk_Window tkwin, Tk_3DBorder border, int which); /* 15 */ HDC (*tkWinGetDrawableDC) (Display *display, Drawable d, TkWinDCState *state); /* 16 */ - int (*tkWinGetModifierState) (void); /* 17 */ + unsigned int (*tkWinGetModifierState) (void); /* 17 */ HPALETTE (*tkWinGetSystemPalette) (void); /* 18 */ HWND (*tkWinGetWrapperWindow) (Tk_Window tkwin); /* 19 */ int (*tkWinHandleMenuEvent) (HWND *phwnd, UINT *pMessage, WPARAM *pwParam, LPARAM *plParam, LRESULT *plResult); /* 20 */ @@ -351,7 +350,7 @@ typedef struct TkIntPlatStubs { Tcl_Obj * (*tkWinGetMenuSystemDefault) (Tk_Window tkwin, const char *dbName, const char *className); /* 32 */ char * (*tkAlignImageData) (XImage *image, int alignment, int bitOrder); /* 33 */ void (*tkWinSetHINSTANCE) (HINSTANCE hInstance); /* 34 */ - int (*tkWinGetPlatformTheme) (void); /* 35 */ + void (*reserved35)(void); LRESULT (__stdcall *tkWinChildProc) (HWND hwnd, UINT message, WPARAM wParam, LPARAM lParam); /* 36 */ void (*reserved37)(void); int (*tkpCmapStressed) (Tk_Window tkwin, Colormap colormap); /* 38 */ @@ -405,7 +404,7 @@ typedef struct TkIntPlatStubs { void (*tkMacOSXWinBounds) (TkWindow *winPtr, void *geometry); /* 36 */ void (*tkMacOSXWindowOffset) (void *wRef, int *xOffset, int *yOffset); /* 37 */ int (*tkSetMacColor) (unsigned long pixel, void *macColor); /* 38 */ - void (*tkSetWMName) (TkWindow *winPtr, Tk_Uid titleUid); /* 39 */ + void (*tkSetWMName) (TkWindow *winPtr, const char *title); /* 39 */ void (*reserved40)(void); int (*tkMacOSXZoomToplevel) (void *whichWindow, short zoomPart); /* 41 */ Tk_Window (*tk_TopCoordsToWindow) (Tk_Window tkwin, int rootX, int rootY, int *newX, int *newY); /* 42 */ @@ -551,8 +550,7 @@ extern const TkIntPlatStubs *tkIntPlatStubsPtr; (tkIntPlatStubsPtr->tkAlignImageData) /* 33 */ #define TkWinSetHINSTANCE \ (tkIntPlatStubsPtr->tkWinSetHINSTANCE) /* 34 */ -#define TkWinGetPlatformTheme \ - (tkIntPlatStubsPtr->tkWinGetPlatformTheme) /* 35 */ +/* Slot 35 is reserved */ #define TkWinChildProc \ (tkIntPlatStubsPtr->tkWinChildProc) /* 36 */ /* Slot 37 is reserved */ @@ -738,6 +736,7 @@ extern const TkIntPlatStubs *tkIntPlatStubsPtr; #ifndef TK_NO_DEPRECATED # define TkMacOSXDrawable Tk_MacOSXGetNSWindowForDrawable +# define TkWinGetPlatformTheme() 3 #endif #undef TCL_STORAGE_CLASS diff --git a/generic/tkIntXlibDecls.h b/generic/tkIntXlibDecls.h index 39258ba..29c5043 100644 --- a/generic/tkIntXlibDecls.h +++ b/generic/tkIntXlibDecls.h @@ -434,8 +434,10 @@ EXTERN char * XSetICValues(XIC xic, ...); EXTERN char * XGetICValues(XIC xic, ...); /* 143 */ EXTERN void XSetICFocus(XIC xic); -/* Slot 144 is reserved */ -/* Slot 145 is reserved */ +/* 144 */ +EXTERN int XXorRegion(Region sra, Region srb, Region dr_return); +/* 145 */ +EXTERN Bool XEqualRegion(Region r1, Region r2); /* Slot 146 is reserved */ /* 147 */ EXTERN void XFreeFontSet(Display *display, XFontSet fontset); @@ -854,8 +856,10 @@ EXTERN char * XSetICValues(XIC xic, ...); EXTERN char * XGetICValues(XIC xic, ...); /* 143 */ EXTERN void XSetICFocus(XIC xic); -/* Slot 144 is reserved */ -/* Slot 145 is reserved */ +/* 144 */ +EXTERN int XXorRegion(Region sra, Region srb, Region dr_return); +/* 145 */ +EXTERN Bool XEqualRegion(Region r1, Region r2); /* Slot 146 is reserved */ /* 147 */ EXTERN void XFreeFontSet(Display *display, XFontSet fontset); @@ -1046,8 +1050,8 @@ typedef struct TkIntXlibStubs { char * (*xSetICValues) (XIC xic, ...); /* 141 */ char * (*xGetICValues) (XIC xic, ...); /* 142 */ void (*xSetICFocus) (XIC xic); /* 143 */ - void (*reserved144)(void); - void (*reserved145)(void); + int (*xXorRegion) (Region sra, Region srb, Region dr_return); /* 144 */ + Bool (*xEqualRegion) (Region r1, Region r2); /* 145 */ void (*reserved146)(void); void (*xFreeFontSet) (Display *display, XFontSet fontset); /* 147 */ int (*xCloseIM) (XIM im); /* 148 */ @@ -1207,8 +1211,8 @@ typedef struct TkIntXlibStubs { char * (*xSetICValues) (XIC xic, ...); /* 141 */ char * (*xGetICValues) (XIC xic, ...); /* 142 */ void (*xSetICFocus) (XIC xic); /* 143 */ - void (*reserved144)(void); - void (*reserved145)(void); + int (*xXorRegion) (Region sra, Region srb, Region dr_return); /* 144 */ + Bool (*xEqualRegion) (Region r1, Region r2); /* 145 */ void (*reserved146)(void); void (*xFreeFontSet) (Display *display, XFontSet fontset); /* 147 */ int (*xCloseIM) (XIM im); /* 148 */ @@ -1515,8 +1519,10 @@ extern const TkIntXlibStubs *tkIntXlibStubsPtr; (tkIntXlibStubsPtr->xGetICValues) /* 142 */ #define XSetICFocus \ (tkIntXlibStubsPtr->xSetICFocus) /* 143 */ -/* Slot 144 is reserved */ -/* Slot 145 is reserved */ +#define XXorRegion \ + (tkIntXlibStubsPtr->xXorRegion) /* 144 */ +#define XEqualRegion \ + (tkIntXlibStubsPtr->xEqualRegion) /* 145 */ /* Slot 146 is reserved */ #define XFreeFontSet \ (tkIntXlibStubsPtr->xFreeFontSet) /* 147 */ @@ -1821,8 +1827,10 @@ extern const TkIntXlibStubs *tkIntXlibStubsPtr; (tkIntXlibStubsPtr->xGetICValues) /* 142 */ #define XSetICFocus \ (tkIntXlibStubsPtr->xSetICFocus) /* 143 */ -/* Slot 144 is reserved */ -/* Slot 145 is reserved */ +#define XXorRegion \ + (tkIntXlibStubsPtr->xXorRegion) /* 144 */ +#define XEqualRegion \ + (tkIntXlibStubsPtr->xEqualRegion) /* 145 */ /* Slot 146 is reserved */ #define XFreeFontSet \ (tkIntXlibStubsPtr->xFreeFontSet) /* 147 */ diff --git a/generic/tkMain.c b/generic/tkMain.c index ab5bcf4..f06c0eb 100644 --- a/generic/tkMain.c +++ b/generic/tkMain.c @@ -73,10 +73,10 @@ NewNativeObj( #if defined(_WIN32) && defined(UNICODE) Tcl_DStringInit(&ds); - Tcl_WCharToUtfDString(string, wcslen(string), &ds); + Tcl_WCharToUtfDString(string, -1, &ds); str = Tcl_DStringValue(&ds); #else - str = Tcl_ExternalToUtfDString(NULL, (char *)string, strlen(string), &ds); + str = Tcl_ExternalToUtfDString(NULL, (char *)string, -1, &ds); #endif obj = Tcl_NewStringObj(str, Tcl_DStringLength(&ds)); Tcl_DStringFree(&ds); @@ -109,7 +109,7 @@ static int WinIsTty(int fd) { return tclIntPlatStubsPtr->tclpIsAtty(fd); } #endif - handle = GetStdHandle(STD_INPUT_HANDLE + fd); + handle = GetStdHandle(STD_INPUT_HANDLE + (DWORD)fd); /* * If it's a bad or closed handle, then it's been connected to a wish * console window. A character file handle is a tty by definition. @@ -199,7 +199,7 @@ Tk_MainEx( /* We are running win32 Tk under Cygwin, so let's check * whether the env("DISPLAY") variable or the -display * argument is set. If so, we really want to run the - * Tk_MainEx function of libtcl9tk9.?.dll, not this one. */ + * Tk_MainEx function of cygtcl9tk9.?.dll, not this one. */ if (Tcl_GetVar2(interp, "env", "DISPLAY", TCL_GLOBAL_ONLY)) { loadCygwinTk: TkCygwinMainEx(argc, argv, appInitProc, interp); diff --git a/generic/tkPack.c b/generic/tkPack.c index d54c03e..09fe4c3 100644 --- a/generic/tkPack.c +++ b/generic/tkPack.c @@ -233,7 +233,7 @@ Tk_PackObjCmd( if (argv2[0] != '.') { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad argument \"%s\": must be name of window", argv2)); - Tcl_SetErrorCode(interp, "TK", "VALUE", "WINDOW_PATH", NULL); + Tcl_SetErrorCode(interp, "TK", "VALUE", "WINDOW_PATH", (char *)NULL); return TCL_ERROR; } return ConfigureContent(interp, tkwin, objc-2, objv+2); @@ -279,7 +279,7 @@ Tk_PackObjCmd( if (contentPtr->containerPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "window \"%s\" isn't packed", argv2)); - Tcl_SetErrorCode(interp, "TK", "PACK", "NOT_PACKED", NULL); + Tcl_SetErrorCode(interp, "TK", "PACK", "NOT_PACKED", (char *)NULL); return TCL_ERROR; } @@ -1252,7 +1252,7 @@ ConfigureContent( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't pack \"%s\": it's a top-level window", Tcl_GetString(objv[j]))); - Tcl_SetErrorCode(interp, "TK", "GEOMETRY", "TOPLEVEL", NULL); + Tcl_SetErrorCode(interp, "TK", "GEOMETRY", "TOPLEVEL", (char *)NULL); return TCL_ERROR; } if (!(contentPtr = GetPacker(content))) { @@ -1281,7 +1281,7 @@ ConfigureContent( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "extra option \"%s\" (option with no value?)", Tcl_GetString(objv[i]))); - Tcl_SetErrorCode(interp, "TK", "PACK", "BAD_PARAMETER", NULL); + Tcl_SetErrorCode(interp, "TK", "PACK", "BAD_PARAMETER", (char *)NULL); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[i], optionStrings, @@ -1365,7 +1365,7 @@ ConfigureContent( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad fill style \"%s\": must be " "none, x, y, or both", string)); - Tcl_SetErrorCode(interp, "TK", "VALUE", "FILL", NULL); + Tcl_SetErrorCode(interp, "TK", "VALUE", "FILL", (char *)NULL); return TCL_ERROR; } break; @@ -1393,7 +1393,7 @@ ConfigureContent( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad ipadx value \"%s\": must be positive screen" " distance", Tcl_GetString(objv[i+1]))); - Tcl_SetErrorCode(interp, "TK", "VALUE", "INT_PAD", NULL); + Tcl_SetErrorCode(interp, "TK", "VALUE", "INT_PAD", (char *)NULL); return TCL_ERROR; } contentPtr->iPadX = tmp * 2; @@ -1404,7 +1404,7 @@ ConfigureContent( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad ipady value \"%s\": must be positive screen" " distance", Tcl_GetString(objv[i+1]))); - Tcl_SetErrorCode(interp, "TK", "VALUE", "INT_PAD", NULL); + Tcl_SetErrorCode(interp, "TK", "VALUE", "INT_PAD", (char *)NULL); return TCL_ERROR; } contentPtr->iPadY = tmp * 2; @@ -1486,14 +1486,14 @@ ConfigureContent( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't pack \"%s\" inside \"%s\"", Tcl_GetString(objv[j]), Tk_PathName(containerPtr->tkwin))); - Tcl_SetErrorCode(interp, "TK", "GEOMETRY", "HIERARCHY", NULL); + Tcl_SetErrorCode(interp, "TK", "GEOMETRY", "HIERARCHY", (char *)NULL); return TCL_ERROR; } } if (content == containerPtr->tkwin) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't pack \"%s\" inside itself", Tcl_GetString(objv[j]))); - Tcl_SetErrorCode(interp, "TK", "GEOMETRY", "SELF", NULL); + Tcl_SetErrorCode(interp, "TK", "GEOMETRY", "SELF", (char *)NULL); return TCL_ERROR; } @@ -1507,7 +1507,7 @@ ConfigureContent( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't put \"%s\" inside \"%s\": would cause management loop", Tcl_GetString(objv[j]), Tk_PathName(containerPtr->tkwin))); - Tcl_SetErrorCode(interp, "TK", "GEOMETRY", "LOOP", NULL); + Tcl_SetErrorCode(interp, "TK", "GEOMETRY", "LOOP", (char *)NULL); return TCL_ERROR; } } diff --git a/generic/tkPanedWindow.c b/generic/tkPanedWindow.c index 04494f0..e6c0884 100644 --- a/generic/tkPanedWindow.c +++ b/generic/tkPanedWindow.c @@ -2490,7 +2490,7 @@ SetSticky( internalPtr = ComputeSlotAddress(recordPtr, internalOffset); - if (flags & TK_OPTION_NULL_OK && TkObjIsEmpty(*value)) { + if ((flags & TK_OPTION_NULL_OK) && TkObjIsEmpty(*value)) { *value = NULL; } else { /* diff --git a/generic/tkSelect.h b/generic/tkSelect.h index bac24d7..e6aaff2 100644 --- a/generic/tkSelect.h +++ b/generic/tkSelect.h @@ -123,6 +123,16 @@ typedef struct TkClipboardTarget { } TkClipboardTarget; /* + * Options enum for the TkClipboardObjCmd. These are defined here + * so they can be used as an argument to TkSelUpdateClipboard. + */ + +typedef enum { + CLIPBOARD_APPEND, CLIPBOARD_CLEAR, CLIPBOARD_GET +} clipboardOption; + + +/* * It is possible for a Tk_SelectionProc to delete the handler that it * represents. If this happens, the code that is retrieving the selection * needs to know about it so it doesn't use the now-defunct handler structure. @@ -160,8 +170,7 @@ MODULE_SCOPE Tcl_Size TkSelDefaultSelection(TkSelectionInfo *infoPtr, Atom target, char *buffer, Tcl_Size maxBytes, Atom *typePtr); #ifndef TkSelUpdateClipboard -MODULE_SCOPE void TkSelUpdateClipboard(TkWindow *winPtr, - TkClipboardTarget *targetPtr); +MODULE_SCOPE void TkSelUpdateClipboard(TkWindow *winPtr, clipboardOption option); #endif #endif /* _TKSELECT */ diff --git a/generic/tkSquare.c b/generic/tkSquare.c index b647861..b9a7f18 100644 --- a/generic/tkSquare.c +++ b/generic/tkSquare.c @@ -23,7 +23,6 @@ # define USE_TK_STUBS #endif #include "tkInt.h" -#include <stdbool.h> /* * A data structure of the following type is kept for each square widget diff --git a/generic/tkStubInit.c b/generic/tkStubInit.c index b3fe123..929d5f9 100644 --- a/generic/tkStubInit.c +++ b/generic/tkStubInit.c @@ -188,7 +188,6 @@ TkPutImage( # define TkWinDialogDebug 0 # define TkWinGetMenuSystemDefault 0 # define TkWinSetHINSTANCE 0 -# define TkWinGetPlatformTheme 0 # define TkWinChildProc 0 # endif @@ -466,7 +465,7 @@ static const TkIntPlatStubs tkIntPlatStubs = { TkWinGetMenuSystemDefault, /* 32 */ TkAlignImageData, /* 33 */ TkWinSetHINSTANCE, /* 34 */ - TkWinGetPlatformTheme, /* 35 */ + 0, /* 35 */ TkWinChildProc, /* 36 */ 0, /* 37 */ TkpCmapStressed, /* 38 */ @@ -732,8 +731,8 @@ static const TkIntXlibStubs tkIntXlibStubs = { XSetICValues, /* 141 */ XGetICValues, /* 142 */ XSetICFocus, /* 143 */ - 0, /* 144 */ - 0, /* 145 */ + XXorRegion, /* 144 */ + XEqualRegion, /* 145 */ 0, /* 146 */ XFreeFontSet, /* 147 */ XCloseIM, /* 148 */ @@ -893,8 +892,8 @@ static const TkIntXlibStubs tkIntXlibStubs = { XSetICValues, /* 141 */ XGetICValues, /* 142 */ XSetICFocus, /* 143 */ - 0, /* 144 */ - 0, /* 145 */ + XXorRegion, /* 144 */ + XEqualRegion, /* 145 */ 0, /* 146 */ XFreeFontSet, /* 147 */ XCloseIM, /* 148 */ diff --git a/generic/tkText.c b/generic/tkText.c index 8079e60..6ac61cb 100644 --- a/generic/tkText.c +++ b/generic/tkText.c @@ -720,7 +720,7 @@ TextWidgetObjCmd( goto done; } if (TkTextIndexBbox(textPtr, indexPtr, &x, &y, &width, &height, - NULL) == 0) { + NULL, NULL) == 0) { Tcl_Obj *listObj = Tcl_NewListObj(0, NULL); Tcl_ListObjAppendElement(interp, listObj, Tcl_NewWideIntObj(x)); @@ -3647,12 +3647,13 @@ TextBlinkProc( } redrawInsert: TkTextMarkSegToIndex(textPtr, textPtr->insertMarkPtr, &index); - if (TkTextIndexBbox(textPtr, &index, &x, &y, &w, &h, &charWidth) == 0) { + if (TkTextIndexBbox(textPtr, &index, &x, &y, &w, &h, + &charWidth, NULL) == 0) { int insertWidth; Tk_GetPixelsFromObj(NULL, textPtr->tkwin, textPtr->insertWidthObj, &insertWidth); if (textPtr->insertCursorType) { /* Block cursor */ - TkTextRedrawRegion(textPtr, x - textPtr->width / 2, y, + TkTextRedrawRegion(textPtr, x - insertWidth / 2, y, charWidth + insertWidth / 2, h); } else { /* I-beam cursor */ @@ -6798,7 +6799,7 @@ SetLineStartEnd( internalPtr = NULL; } - if (flags & TK_OPTION_NULL_OK && TkObjIsEmpty(*value)) { + if ((flags & TK_OPTION_NULL_OK) && TkObjIsEmpty(*value)) { *value = NULL; } else { int line; diff --git a/generic/tkText.h b/generic/tkText.h index 8f5481a..f8ca191 100644 --- a/generic/tkText.h +++ b/generic/tkText.h @@ -1035,7 +1035,8 @@ MODULE_SCOPE void TkTextBindProc(void *clientData, MODULE_SCOPE void TkTextSelectionEvent(TkText *textPtr); MODULE_SCOPE int TkTextIndexBbox(TkText *textPtr, const TkTextIndex *indexPtr, int *xPtr, int *yPtr, - int *widthPtr, int *heightPtr, int *charWidthPtr); + int *widthPtr, int *heightPtr, int *charWidthPtr, + int *cursorWidthPtr); MODULE_SCOPE int TkTextCharLayoutProc(TkText *textPtr, TkTextIndex *indexPtr, TkTextSegment *segPtr, Tcl_Size offset, int maxX, Tcl_Size maxChars, int noBreakYet, @@ -1092,7 +1093,7 @@ MODULE_SCOPE TkTextIndex *TkTextMakeCharIndex(TkTextBTree tree, TkText *textPtr, MODULE_SCOPE int TkTextMeasureDown(TkText *textPtr, TkTextIndex *srcPtr, int distance); MODULE_SCOPE void TkTextFreeElideInfo(TkTextElideInfo *infoPtr); -MODULE_SCOPE int TkTextIsElided(const TkText *textPtr, +MODULE_SCOPE bool TkTextIsElided(const TkText *textPtr, const TkTextIndex *indexPtr, TkTextElideInfo *infoPtr); MODULE_SCOPE int TkTextMakePixelIndex(TkText *textPtr, diff --git a/generic/tkTextBTree.c b/generic/tkTextBTree.c index 7a65ee1..8187ff5 100644 --- a/generic/tkTextBTree.c +++ b/generic/tkTextBTree.c @@ -3507,7 +3507,7 @@ TkBTreeGetTags( *---------------------------------------------------------------------- */ -int +bool TkTextIsElided( const TkText *textPtr, /* Overall information about text widget. */ const TkTextIndex *indexPtr,/* The character in the text for which display @@ -3523,7 +3523,8 @@ TkTextIsElided( Tcl_Size i; TkTextElideInfo *infoPtr; TkTextLine *linePtr; - int elide, index; + bool elide; + int index; if (elideInfo == NULL) { infoPtr = (TkTextElideInfo *)ckalloc(sizeof(TkTextElideInfo)); @@ -3653,7 +3654,7 @@ TkTextIsElided( } } - elide = infoPtr->elide; + elide = (infoPtr->elide != 0); if (elideInfo == NULL) { if (LOTSA_TAGS < infoPtr->numTags) { diff --git a/generic/tkTextDisp.c b/generic/tkTextDisp.c index c8df68b..93e9c26 100644 --- a/generic/tkTextDisp.c +++ b/generic/tkTextDisp.c @@ -1170,7 +1170,8 @@ LayoutDLine( * numBytes > 0. Used to drop 0-sized chunks * from the end of the line. */ Tcl_Size byteOffset; - int ascent, descent, code, elide, elidesize; + int ascent, descent, code, elidesize; + bool elide; StyleValues *sValuePtr; TkTextElideInfo info; /* Keep track of elide state. */ @@ -7357,15 +7358,24 @@ TkTextIndexBbox( * coordinate. */ int *widthPtr, int *heightPtr, /* Filled in with index's dimensions. */ - int *charWidthPtr) /* If the 'index' is at the end of a display + int *charWidthPtr, /* If the 'index' is at the end of a display * line and therefore takes up a very large * width, this is used to return the smaller * width actually desired by the index. */ + int *cursorWidthPtr) /* Receives the same value as 'charWidthPtr' + * except when indexPtr points to a Tab. Then + * 'cursorWidthPtr' gets reduced to the width + * of a single space. */ { TextDInfo *dInfoPtr = textPtr->dInfoPtr; DLine *dlPtr; TkTextDispChunk *chunkPtr; Tcl_Size byteCount; + int dummy; + + if (charWidthPtr == NULL) { + charWidthPtr = &dummy; + } /* * Make sure that all of the screen layout information is up to date. @@ -7431,20 +7441,16 @@ TkTextIndexBbox( * line. */ - if (charWidthPtr != NULL) { - *charWidthPtr = dInfoPtr->maxX - *xPtr; - if (*charWidthPtr > textPtr->charWidth) { - *charWidthPtr = textPtr->charWidth; - } + *charWidthPtr = dInfoPtr->maxX - *xPtr; + if (*charWidthPtr > textPtr->charWidth) { + *charWidthPtr = textPtr->charWidth; } if (*xPtr > dInfoPtr->maxX) { *xPtr = dInfoPtr->maxX; } *widthPtr = dInfoPtr->maxX - *xPtr; } else { - if (charWidthPtr != NULL) { - *charWidthPtr = *widthPtr; - } + *charWidthPtr = *widthPtr; } if (*widthPtr == 0) { /* @@ -7472,6 +7478,30 @@ TkTextIndexBbox( return -1; } } + + /* + * For a block cursor on a tab, cursorWidthPtr is the whitespace width. + */ + + if (cursorWidthPtr != NULL) { + *cursorWidthPtr = *charWidthPtr; + if (chunkPtr->bboxProc == CharBboxProc) { + CharInfo *ciPtr = (CharInfo*)chunkPtr->clientData; +#ifdef TK_LAYOUT_WITH_BASE_CHUNKS + BaseCharInfo *bciPtr = + (BaseCharInfo*)ciPtr->baseChunkPtr->clientData; + char *chars = Tcl_DStringValue(&bciPtr->baseChars); + + if (chars[ciPtr->baseOffset + byteCount] == '\t') +#else + if (ciPtr->chars[byteCount] == '\t') +#endif + { + CharChunkMeasureChars(chunkPtr, " ", 1, 0, 1, + 0, -1, 0, cursorWidthPtr); + } + } + } return 0; } diff --git a/generic/tkTextIndex.c b/generic/tkTextIndex.c index a77fd9a..6b7f872 100644 --- a/generic/tkTextIndex.c +++ b/generic/tkTextIndex.c @@ -1559,7 +1559,7 @@ TkTextIndexForwChars( Tcl_Size byteOffset; char *start, *end, *p; int ch; - int elide = 0; + bool elide = false; int checkElided = (type & COUNT_DISPLAY); if (charCount < 0) { @@ -1636,7 +1636,7 @@ TkTextIndexForwChars( * elide will be zero, of course). */ - elide = 0; + elide = false; while (--infoPtr->elidePriority > 0) { if (infoPtr->tagCnts[infoPtr->elidePriority] & 1) { @@ -1822,8 +1822,8 @@ TkTextIndexCount( TkTextSegment *segPtr, *seg2Ptr = NULL; TkTextElideInfo *infoPtr = NULL; Tcl_Size byteOffset, maxBytes, count = 0; - int elide = 0; - int checkElided = (type & COUNT_DISPLAY); + bool elide = false; + bool checkElided = (type & COUNT_DISPLAY) != 0; /* * Find seg that contains src index, and remember how many bytes not to @@ -2086,8 +2086,8 @@ TkTextIndexBackChars( TkTextElideInfo *infoPtr = NULL; int lineIndex, segSize; const char *p, *start, *end; - int elide = 0; - int checkElided = (type & COUNT_DISPLAY); + bool elide = false; + bool checkElided = (type & COUNT_DISPLAY) != 0; if (charCount < 0) { TkTextIndexForwChars(textPtr, srcPtr, -charCount, dstPtr, type); @@ -2174,7 +2174,7 @@ TkTextIndexBackChars( * will be zero, of course). */ - elide = 0; + elide = false; while (--infoPtr->elidePriority > 0) { if (infoPtr->tagCnts[infoPtr->elidePriority] & 1) { elide = infoPtr->tagPtrs[ diff --git a/generic/tkTextMark.c b/generic/tkTextMark.c index fe25f3c..cdb0612 100644 --- a/generic/tkTextMark.c +++ b/generic/tkTextMark.c @@ -625,15 +625,17 @@ TkTextInsertDisplayProc( TkTextIndex index; int halfWidth, insertWidth, insertBorderWidth; int rightSideWidth; - int ix = 0, iy = 0, iw = 0, ih = 0, charWidth = 0; + int ix = 0, iy = 0, iw = 0, ih = 0, charWidth = 0, cursorWidth = 0; Tk_GetPixelsFromObj(NULL, textPtr->tkwin, textPtr->insertWidthObj, &insertWidth); Tk_GetPixelsFromObj(NULL, textPtr->tkwin, textPtr->insertBorderWidthObj, &insertBorderWidth); halfWidth = insertWidth/2; if (textPtr->insertCursorType) { TkTextMarkSegToIndex(textPtr, textPtr->insertMarkPtr, &index); - TkTextIndexBbox(textPtr, &index, &ix, &iy, &iw, &ih, &charWidth); + TkTextIndexBbox(textPtr, &index, &ix, &iy, &iw, &ih, &charWidth, + &cursorWidth); rightSideWidth = charWidth + halfWidth; + charWidth = cursorWidth; } else { rightSideWidth = halfWidth; } diff --git a/generic/tkTextTag.c b/generic/tkTextTag.c index 9c65f1b..4ecf446 100644 --- a/generic/tkTextTag.c +++ b/generic/tkTextTag.c @@ -281,7 +281,7 @@ TkTextTagCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "requested illegal events; only key, button, motion," " enter, leave, and virtual events may be used", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "TEXT", "TAG_BIND_EVENT",NULL); + Tcl_SetErrorCode(interp, "TK", "TEXT", "TAG_BIND_EVENT", (char *)NULL); return TCL_ERROR; } } else if (objc == 5) { diff --git a/generic/tkWindow.c b/generic/tkWindow.c index a454d1a..5fd58bf 100644 --- a/generic/tkWindow.c +++ b/generic/tkWindow.c @@ -1037,6 +1037,9 @@ TkCreateMainWindow( #ifdef STATIC_BUILD ".static" #endif +#if (defined(__MSVCRT__) || defined(_UCRT)) && (!defined(__USE_MINGW_ANSI_STDIO) || __USE_MINGW_ANSI_STDIO) + ".stdio-mingw" +#endif #if defined(_WIN32) ".win32" #endif @@ -2985,7 +2988,7 @@ DeleteWindowsExitProc( static HMODULE tkcygwindll = NULL; /* - * Run Tk_MainEx from libtcl9tk9.?.dll + * Run Tk_MainEx from cygtcl9tk9.?.dll * * This function is only ever called from wish9.?.exe, the cygwin port of Tcl. * This means that the system encoding is utf-8, so we don't have to do any @@ -3006,12 +3009,12 @@ TkCygwinMainEx( size_t len; void (*tkmainex)(Tcl_Size, char **, Tcl_AppInitProc *, Tcl_Interp *); - /* construct "<path>/libtcl9tk9.?.dll", from "<path>/tcl9tk9?.dll" */ + /* construct "<path>/cygtcl9tk9.?.dll", from "<path>/tcl9tk9?.dll" */ len = GetModuleFileNameW((HINSTANCE)Tk_GetHINSTANCE(), name, MAX_PATH); - name[len-2] = '.'; - name[len-1] = name[len-5]; - wcscpy(name+len, L".dll"); - memcpy(name+len-12, L"libtcl9tk9", 10 * sizeof(WCHAR)); + name[len-2] = '.'; /* "<path>/tcl9tk9?.d.l" */ + name[len-1] = name[len-5]; /* "<path>/tcl9tk9?.d.?" */ + wcscpy(name+len, L".dll"); /* "<path>/tcl9tk9?.d.?.dll" */ + memcpy(name+len-12, L"cygtcl9tk9", 10 * sizeof(WCHAR)); /* "<path>/cygtcl9tk9.?.dll" */ tkcygwindll = LoadLibraryW(name); if (tkcygwindll) { diff --git a/generic/ttk/ttk.decls b/generic/ttk/ttk.decls index ff2c18d..55be583 100644 --- a/generic/ttk/ttk.decls +++ b/generic/ttk/ttk.decls @@ -21,7 +21,7 @@ declare 4 { Tcl_Interp *interp, void *deleteData, Ttk_CleanupProc *cleanupProc) } -declare 5 { +declare 5 {deprecated {Use Ttk_RegisterElement}} { int Ttk_RegisterElementSpec( Ttk_Theme theme, const char *elementName, diff --git a/generic/ttk/ttkBlink.c b/generic/ttk/ttkBlink.c index 8f4c8af..5fddbc8 100644 --- a/generic/ttk/ttkBlink.c +++ b/generic/ttk/ttkBlink.c @@ -97,7 +97,7 @@ CursorBlinkProc(void *clientData) int blinkTime; if (cm->owner->flags & CURSOR_ON) { - cm->owner->flags &= ~CURSOR_ON; + cm->owner->flags &= ~(unsigned)CURSOR_ON; blinkTime = cm->offTime; } else { cm->owner->flags |= CURSOR_ON; @@ -113,7 +113,7 @@ CursorBlinkProc(void *clientData) static void LoseCursor(CursorManager *cm, WidgetCore *corePtr) { if (corePtr->flags & CURSOR_ON) { - corePtr->flags &= ~CURSOR_ON; + corePtr->flags &= ~(unsigned)CURSOR_ON; TtkRedisplayWidget(corePtr); } if (cm->owner == corePtr) { @@ -130,10 +130,12 @@ static void LoseCursor(CursorManager *cm, WidgetCore *corePtr) */ static void ClaimCursor(CursorManager *cm, WidgetCore *corePtr) { - if (cm->owner == corePtr) + if (cm->owner == corePtr) { return; - if (cm->owner) + } + if (cm->owner) { LoseCursor(cm, cm->owner); + } corePtr->flags |= CURSOR_ON; TtkRedisplayWidget(corePtr); @@ -161,18 +163,21 @@ CursorEventProc(void *clientData, XEvent *eventPtr) switch (eventPtr->type) { case DestroyNotify: - if (cm->owner == corePtr) + if (cm->owner == corePtr) { LoseCursor(cm, corePtr); + } Tk_DeleteEventHandler( corePtr->tkwin, CursorEventMask, CursorEventProc, clientData); break; case FocusIn: - if (RealFocusEvent(eventPtr->xfocus.detail)) + if (RealFocusEvent(eventPtr->xfocus.detail)) { ClaimCursor(cm, corePtr); + } break; case FocusOut: - if (RealFocusEvent(eventPtr->xfocus.detail)) + if (RealFocusEvent(eventPtr->xfocus.detail)) { LoseCursor(cm, corePtr); + } break; } } @@ -181,16 +186,18 @@ void TtkSetBlinkCursorOnTime(Tcl_Interp* interp, int onTime) { CursorManager* cm = GetCursorManager(interp); - if (onTime >= 0) + if (onTime >= 0) { cm->onTime = onTime; + } } void TtkSetBlinkCursorOffTime(Tcl_Interp* interp, int offTime) { CursorManager* cm = GetCursorManager(interp); - if (offTime >= 0) + if (offTime >= 0) { cm->offTime = offTime; + } } /* diff --git a/generic/ttk/ttkButton.c b/generic/ttk/ttkButton.c index 0cf0517..1db042f 100644 --- a/generic/ttk/ttkButton.c +++ b/generic/ttk/ttkButton.c @@ -533,10 +533,12 @@ CheckbuttonPostConfigure(Tcl_Interp *interp, void *recordPtr, int mask) Checkbutton *checkPtr = (Checkbutton *)recordPtr; int status = TCL_OK; - if (checkPtr->checkbutton.variableTrace) + if (checkPtr->checkbutton.variableTrace) { status = Ttk_FireTrace(checkPtr->checkbutton.variableTrace); - if (status == TCL_OK && !WidgetDestroyed(&checkPtr->core)) + } + if (status == TCL_OK && !WidgetDestroyed(&checkPtr->core)) { status = BasePostConfigure(interp, recordPtr, mask); + } return status; } @@ -556,16 +558,17 @@ CheckbuttonInvokeCommand( Tcl_WrongNumArgs(interp, 1, objv, "invoke"); return TCL_ERROR; } - if (corePtr->state & TTK_STATE_DISABLED) + if (corePtr->state & TTK_STATE_DISABLED) { return TCL_OK; - + } /* * Toggle the selected state. */ - if (corePtr->state & TTK_STATE_SELECTED) + if (corePtr->state & TTK_STATE_SELECTED) { newValue = checkPtr->checkbutton.offValueObj; - else + } else { newValue = checkPtr->checkbutton.onValueObj; + } if (checkPtr->checkbutton.variableObj == NULL || *Tcl_GetString(checkPtr->checkbutton.variableObj) == '\0') @@ -576,8 +579,9 @@ CheckbuttonInvokeCommand( == NULL) return TCL_ERROR; - if (WidgetDestroyed(corePtr)) + if (WidgetDestroyed(corePtr)) { return TCL_ERROR; + } return Tcl_EvalObjEx(interp, checkPtr->checkbutton.commandObj, TCL_EVAL_GLOBAL); @@ -721,10 +725,12 @@ RadiobuttonPostConfigure(Tcl_Interp *interp, void *recordPtr, int mask) Radiobutton *radioPtr = (Radiobutton *)recordPtr; int status = TCL_OK; - if (radioPtr->radiobutton.variableTrace) + if (radioPtr->radiobutton.variableTrace) { status = Ttk_FireTrace(radioPtr->radiobutton.variableTrace); - if (status == TCL_OK && !WidgetDestroyed(&radioPtr->core)) + } + if (status == TCL_OK && !WidgetDestroyed(&radioPtr->core)) { status = BasePostConfigure(interp, recordPtr, mask); + } return status; } @@ -743,8 +749,9 @@ RadiobuttonInvokeCommand( Tcl_WrongNumArgs(interp, 1, objv, "invoke"); return TCL_ERROR; } - if (corePtr->state & TTK_STATE_DISABLED) + if (corePtr->state & TTK_STATE_DISABLED) { return TCL_OK; + } if (Tcl_ObjSetVar2(interp, radioPtr->radiobutton.variableObj, NULL, @@ -753,8 +760,9 @@ RadiobuttonInvokeCommand( == NULL) return TCL_ERROR; - if (WidgetDestroyed(corePtr)) + if (WidgetDestroyed(corePtr)) { return TCL_ERROR; + } return Tcl_EvalObjEx(interp, radioPtr->radiobutton.commandObj, TCL_EVAL_GLOBAL); diff --git a/generic/ttk/ttkClamTheme.c b/generic/ttk/ttkClamTheme.c index 91c15fc..a8c42e0 100644 --- a/generic/ttk/ttkClamTheme.c +++ b/generic/ttk/ttkClamTheme.c @@ -378,8 +378,8 @@ static void IndicatorElementSize( double scalingLevel = TkScalingLevel(tkwin); Ttk_GetPaddingFromObj(NULL, tkwin, indicator->marginObj, &margins); - *widthPtr = spec->width * scalingLevel + Ttk_PaddingWidth(margins); - *heightPtr = spec->height * scalingLevel + Ttk_PaddingHeight(margins); + *widthPtr = (int)(spec->width * scalingLevel) + Ttk_PaddingWidth(margins); + *heightPtr = (int)(spec->height * scalingLevel) + Ttk_PaddingHeight(margins); } static void ColorToStr( @@ -408,8 +408,8 @@ static void IndicatorElementDraw( Ttk_Padding padding; const IndicatorSpec *spec = (const IndicatorSpec *)clientData; double scalingLevel = TkScalingLevel(tkwin); - int width = spec->width * scalingLevel; - int height = spec->height * scalingLevel; + int width = (int)(spec->width * scalingLevel); + int height = (int)(spec->height * scalingLevel); char upperBdColorStr[7], lowerBdColorStr[7], bgColorStr[7], fgColorStr[7]; unsigned int selected = (state & TTK_STATE_SELECTED); @@ -675,8 +675,8 @@ static void TroughElementDraw( GC gcb = Ttk_GCForColor(tkwin,sb->borderColorObj,d); GC gct = Ttk_GCForColor(tkwin,sb->troughColorObj,d); - XFillRectangle(Tk_Display(tkwin), d, gct, b.x, b.y, b.width-1, b.height-1); - XDrawRectangle(Tk_Display(tkwin), d, gcb, b.x, b.y, b.width-1, b.height-1); + XFillRectangle(Tk_Display(tkwin), d, gct, b.x, b.y, (unsigned)b.width-1, (unsigned)b.height-1); + XDrawRectangle(Tk_Display(tkwin), d, gcb, b.x, b.y, (unsigned)b.width-1, (unsigned)b.height-1); } static const Ttk_ElementSpec TroughElementSpec = { @@ -721,7 +721,7 @@ static void ThumbElementDraw( sb->borderColorObj, sb->lightColorObj, sb->darkColorObj); XFillRectangle( Tk_Display(tkwin), d, BackgroundGC(tkwin, sb->backgroundObj), - b.x+2, b.y+2, b.width-4, b.height-4); + b.x+2, b.y+2, (unsigned)b.width-4, (unsigned)b.height-4); /* * Draw grip: @@ -824,7 +824,7 @@ static void PbarElementDraw( sb->borderColorObj, sb->lightColorObj, sb->darkColorObj); XFillRectangle(Tk_Display(tkwin), d, BackgroundGC(tkwin, sb->backgroundObj), - b.x+2, b.y+2, b.width-4, b.height-4); + b.x+2, b.y+2, (unsigned)b.width-4, (unsigned)b.height-4); } } @@ -847,7 +847,7 @@ static void ArrowElementSize( ScrollbarElement *sb = (ScrollbarElement *)elementRecord; ArrowDirection direction = (ArrowDirection)PTR2INT(clientData); double scalingLevel = TkScalingLevel(tkwin); - Ttk_Padding padding = Ttk_UniformPadding(round(3 * scalingLevel)); + Ttk_Padding padding = Ttk_UniformPadding((short)round(3 * scalingLevel)); int size = SCROLLBAR_THICKNESS; Tk_GetPixelsFromObj(NULL, tkwin, sb->arrowSizeObj, &size); @@ -870,7 +870,7 @@ static void ArrowElementDraw( ScrollbarElement *sb = (ScrollbarElement *)elementRecord; ArrowDirection direction = (ArrowDirection)PTR2INT(clientData); double scalingLevel = TkScalingLevel(tkwin); - Ttk_Padding padding = Ttk_UniformPadding(round(3 * scalingLevel)); + Ttk_Padding padding = Ttk_UniformPadding((short)round(3 * scalingLevel)); int cx, cy; GC gc = Ttk_GCForColor(tkwin, sb->arrowColorObj, d); @@ -879,7 +879,7 @@ static void ArrowElementDraw( XFillRectangle( Tk_Display(tkwin), d, BackgroundGC(tkwin, sb->backgroundObj), - b.x+2, b.y+2, b.width-4, b.height-4); + b.x+2, b.y+2, (unsigned)b.width-4, (unsigned)b.height-4); b = Ttk_PadBox(b, padding); @@ -925,7 +925,7 @@ static void SpinboxArrowElementSize( ScrollbarElement *sb = (ScrollbarElement *)elementRecord; ArrowDirection direction = (ArrowDirection)PTR2INT(clientData); double scalingLevel = TkScalingLevel(tkwin); - Ttk_Padding padding = Ttk_UniformPadding(round(3 * scalingLevel)); + Ttk_Padding padding = Ttk_UniformPadding((short)round(3 * scalingLevel)); int size = 10; Tk_GetPixelsFromObj(NULL, tkwin, sb->arrowSizeObj, &size); diff --git a/generic/ttk/ttkClassicTheme.c b/generic/ttk/ttkClassicTheme.c index e4dffff..c178ccb 100644 --- a/generic/ttk/ttkClassicTheme.c +++ b/generic/ttk/ttkClassicTheme.c @@ -67,7 +67,7 @@ static void HighlightElementDraw( GC gc = Tk_GCForColor(highlightColor, d); if (defaultState == TTK_BUTTON_DEFAULT_NORMAL) { TkDrawInsetFocusHighlight(tkwin, gc, highlightThickness, d, - round(5 * TkScalingLevel(tkwin))); + (int)round(5 * TkScalingLevel(tkwin))); } else { Tk_DrawFocusHighlight(tkwin, gc, highlightThickness, d); } @@ -129,7 +129,7 @@ static void ButtonBorderElementSize( Ttk_GetButtonDefaultStateFromObj(NULL, bd->defaultStateObj, &defaultState); if (defaultState != TTK_BUTTON_DEFAULT_DISABLED) { - borderWidth += round(5 * TkScalingLevel(tkwin)); + borderWidth += (int)round(5 * TkScalingLevel(tkwin)); } *paddingPtr = Ttk_UniformPadding((short)borderWidth); } @@ -169,7 +169,7 @@ static void ButtonBorderElementDraw( case TTK_BUTTON_DEFAULT_DISABLED : break; case TTK_BUTTON_DEFAULT_NORMAL : - inset += round(5 * TkScalingLevel(tkwin)); + inset += (int)round(5 * TkScalingLevel(tkwin)); break; case TTK_BUTTON_DEFAULT_ACTIVE : Tk_Draw3DRectangle(tkwin, d, border, @@ -342,14 +342,14 @@ static void DiamondIndicatorElementDraw( diameter = b.width < b.height ? b.width : b.height; radius = diameter / 2; - points[0].x = b.x; - points[0].y = b.y + radius; - points[1].x = b.x + radius; - points[1].y = b.y + 2*radius; - points[2].x = b.x + 2*radius; - points[2].y = b.y + radius; - points[3].x = b.x + radius; - points[3].y = b.y; + points[0].x = (short)b.x; + points[0].y = (short)(b.y + radius); + points[1].x = (short)(b.x + radius); + points[1].y = (short)(b.y + 2*radius); + points[2].x = (short)(b.x + 2*radius); + points[2].y = (short)(b.y + radius); + points[3].x = (short)(b.x + radius); + points[3].y = (short)b.y; Tk_Fill3DPolygon(tkwin,d,interior,points,4,borderWidth,TK_RELIEF_FLAT); Tk_Draw3DPolygon(tkwin,d,border,points,4,borderWidth,relief); @@ -518,24 +518,24 @@ static void ArrowElementDraw( switch (direction) { case ARROW_UP: - points[2].x = b.x; points[2].y = b.y + size; - points[1].x = b.x + size/2; points[1].y = b.y; - points[0].x = b.x + size; points[0].y = b.y + size; + points[2].x = (short)b.x; points[2].y = (short)(b.y + size); + points[1].x = (short)(b.x + size/2); points[1].y = (short)b.y; + points[0].x = (short)(b.x + size); points[0].y = (short)(b.y + size); break; case ARROW_DOWN: - points[0].x = b.x; points[0].y = b.y; - points[1].x = b.x + size/2; points[1].y = b.y + size; - points[2].x = b.x + size; points[2].y = b.y; + points[0].x = (short)b.x; points[0].y = (short)b.y; + points[1].x = (short)(b.x + size/2); points[1].y = (short)(b.y + size); + points[2].x = (short)(b.x + size); points[2].y = (short)b.y; break; case ARROW_LEFT: - points[0].x = b.x; points[0].y = b.y + size / 2; - points[1].x = b.x + size; points[1].y = b.y + size; - points[2].x = b.x + size; points[2].y = b.y; + points[0].x = (short)b.x; points[0].y = (short)(b.y + size / 2); + points[1].x = (short)(b.x + size); points[1].y = (short)(b.y + size); + points[2].x = (short)(b.x + size); points[2].y = (short)b.y; break; case ARROW_RIGHT: - points[0].x = b.x + size; points[0].y = b.y + size / 2; - points[1].x = b.x; points[1].y = b.y; - points[2].x = b.x; points[2].y = b.y + size; + points[0].x = (short)(b.x + size); points[0].y = (short)(b.y + size / 2); + points[1].x = (short)b.x; points[1].y = (short)b.y; + points[2].x = (short)b.x; points[2].y = (short)(b.y + size); break; } @@ -718,13 +718,15 @@ static void SashElementSize( Tk_GetPixelsFromObj(NULL, tkwin, sash->handleSizeObj, &handleSize); Tk_GetPixelsFromObj(NULL, tkwin, sash->sashPadObj, &sashPad); - if (sashThickness < handleSize + 2*sashPad) + if (sashThickness < handleSize + 2*sashPad) { sashThickness = handleSize + 2*sashPad; + } - if (orient == TTK_ORIENT_HORIZONTAL) + if (orient == TTK_ORIENT_HORIZONTAL) { *heightPtr = sashThickness; - else + } else { *widthPtr = sashThickness; + } } static void SashElementDraw( diff --git a/generic/ttk/ttkDecls.h b/generic/ttk/ttkDecls.h index 9c40904..83a2bca 100644 --- a/generic/ttk/ttkDecls.h +++ b/generic/ttk/ttkDecls.h @@ -54,7 +54,8 @@ TTKAPI void Ttk_RegisterCleanup(Tcl_Interp *interp, void *deleteData, Ttk_CleanupProc *cleanupProc); /* 5 */ -TTKAPI int Ttk_RegisterElementSpec(Ttk_Theme theme, +TTK_DEPRECATED("Use Ttk_RegisterElement") +int Ttk_RegisterElementSpec(Ttk_Theme theme, const char *elementName, const Ttk_ElementSpec *elementSpec, void *clientData); @@ -153,7 +154,7 @@ typedef struct TtkStubs { Ttk_Theme (*ttk_GetCurrentTheme) (Tcl_Interp *interp); /* 2 */ Ttk_Theme (*ttk_CreateTheme) (Tcl_Interp *interp, const char *name, Ttk_Theme parent); /* 3 */ void (*ttk_RegisterCleanup) (Tcl_Interp *interp, void *deleteData, Ttk_CleanupProc *cleanupProc); /* 4 */ - int (*ttk_RegisterElementSpec) (Ttk_Theme theme, const char *elementName, const Ttk_ElementSpec *elementSpec, void *clientData); /* 5 */ + TCL_DEPRECATED_API("Use Ttk_RegisterElement") int (*ttk_RegisterElementSpec) (Ttk_Theme theme, const char *elementName, const Ttk_ElementSpec *elementSpec, void *clientData); /* 5 */ Ttk_ElementClass * (*ttk_RegisterElement) (Tcl_Interp *interp, Ttk_Theme theme, const char *elementName, const Ttk_ElementSpec *elementSpec, void *clientData); /* 6 */ int (*ttk_RegisterElementFactory) (Tcl_Interp *interp, const char *name, Ttk_ElementFactory factoryProc, void *clientData); /* 7 */ void (*ttk_RegisterLayout) (Ttk_Theme theme, const char *className, Ttk_LayoutSpec layoutSpec); /* 8 */ @@ -280,4 +281,8 @@ extern const TtkStubs *ttkStubsPtr; /* !END!: Do not edit above this line. */ +#ifdef TK_NO_DEPRECATED +# undef Ttk_RegisterElementSpec +#endif + #endif /* _TTKDECLS */ diff --git a/generic/ttk/ttkDefaultTheme.c b/generic/ttk/ttkDefaultTheme.c index f1c37a6..9f3c282 100644 --- a/generic/ttk/ttkDefaultTheme.c +++ b/generic/ttk/ttkDefaultTheme.c @@ -59,24 +59,31 @@ static const enum BorderColor thinShadowColors[6][4] = { static void DrawCorner( Tk_Window tkwin, Drawable d, - Tk_3DBorder border, /* get most GCs from here... */ - GC borderGC, /* "window border" color GC */ - int x,int y, int width,int height, /* where to draw */ - int corner, /* 0 => top left; 1 => bottom right */ + Tk_3DBorder border, /* get most GCs from here... */ + GC borderGC, /* "window border" color GC */ + int x, int y, int width, int height, /* where to draw */ + bool corner, /* false => top left; true => bottom right */ enum BorderColor color) { XPoint points[3]; GC gc; --width; --height; - points[0].x = x; points[0].y = y+height; - points[1].x = x+width*corner; points[1].y = y+height*corner; - points[2].x = x+width; points[2].y = y; + points[0].x = x; points[0].y = y+height; + points[1].x = corner ? x + width : x; points[1].y = corner ? y + height : y; + points[2].x = x+width; points[2].y = y; - if (color == BRDR) + if (corner) { + points[2].y -= WIN32_XDRAWLINE_HACK; + } else { + points[2].x += WIN32_XDRAWLINE_HACK; + } + + if (color == BRDR) { gc = borderGC; - else + } else { gc = Tk_3DBorderGC(tkwin, border, (int)color); + } XDrawLines(Tk_Display(tkwin), d, gc, points, 3, CoordModeOrigin); } @@ -90,19 +97,19 @@ static void DrawBorder( switch (borderWidth) { case 2: /* "thick" border */ DrawCorner(tkwin, d, border, borderGC, - b.x, b.y, b.width, b.height, 0,shadowColors[relief][0]); + b.x, b.y, b.width, b.height, false, shadowColors[relief][0]); DrawCorner(tkwin, d, border, borderGC, - b.x+1, b.y+1, b.width-2, b.height-2, 0,shadowColors[relief][1]); + b.x+1, b.y+1, b.width-2, b.height-2, false, shadowColors[relief][1]); DrawCorner(tkwin, d, border, borderGC, - b.x+1, b.y+1, b.width-2, b.height-2, 1,shadowColors[relief][2]); + b.x+1, b.y+1, b.width-2, b.height-2, true, shadowColors[relief][2]); DrawCorner(tkwin, d, border, borderGC, - b.x, b.y, b.width, b.height, 1,shadowColors[relief][3]); + b.x, b.y, b.width, b.height, true, shadowColors[relief][3]); break; case 1: /* "thin" border */ DrawCorner(tkwin, d, border, borderGC, - b.x, b.y, b.width, b.height, 0, thinShadowColors[relief][0]); + b.x, b.y, b.width, b.height, false, thinShadowColors[relief][0]); DrawCorner(tkwin, d, border, borderGC, - b.x, b.y, b.width, b.height, 1, thinShadowColors[relief][1]); + b.x, b.y, b.width, b.height, true, thinShadowColors[relief][1]); break; case 0: /* no border -- do nothing */ break; @@ -122,13 +129,13 @@ static void DrawFieldBorder( { GC borderGC = Tk_GCForColor(borderColor, d); DrawCorner(tkwin, d, border, borderGC, - b.x, b.y, b.width, b.height, 0, DARK); + b.x, b.y, b.width, b.height, false, DARK); DrawCorner(tkwin, d, border, borderGC, - b.x+1, b.y+1, b.width-2, b.height-2, 0, BRDR); + b.x+1, b.y+1, b.width-2, b.height-2, false, BRDR); DrawCorner(tkwin, d, border, borderGC, - b.x+1, b.y+1, b.width-2, b.height-2, 1, LITE); + b.x+1, b.y+1, b.width-2, b.height-2, true, LITE); DrawCorner(tkwin, d, border, borderGC, - b.x, b.y, b.width, b.height, 1, FLAT); + b.x, b.y, b.width, b.height, true, FLAT); return; } @@ -372,10 +379,11 @@ static void FieldElementDraw( XColor *focusColor = Tk_GetColorFromObj(tkwin, field->focusColorObj); GC focusGC = Tk_GCForColor(focusColor, d); - if (focusWidth > 1) { + if (focusWidth > 1 && b.width >= 2 && b.height >= 2) { int x1 = b.x, x2 = b.x + b.width - 1; int y1 = b.y, y2 = b.y + b.height - 1; int w = WIN32_XDRAWLINE_HACK; + GC bgGC = Tk_3DBorderGC(tkwin, border, TK_3D_FLAT_GC); /* * Draw the outer rounded rectangle @@ -394,7 +402,6 @@ static void FieldElementDraw( /* * Fill the inner rectangle */ - GC bgGC = Tk_3DBorderGC(tkwin, border, TK_3D_FLAT_GC); XFillRectangle(disp, d, bgGC, b.x+1, b.y+1, b.width-2, b.height-2); } else { /* @@ -1091,8 +1098,9 @@ static void ThumbElementDraw( /* * Don't draw the thumb if we are disabled. * This makes it behave like Windows ... if that's what we want. - if (state & TTK_STATE_DISABLED) + if (state & TTK_STATE_DISABLED) { return; + } */ Tk_GetReliefFromObj(NULL, thumb->reliefObj, &relief); diff --git a/generic/ttk/ttkElements.c b/generic/ttk/ttkElements.c index e8ff680..304f8ff 100644 --- a/generic/ttk/ttkElements.c +++ b/generic/ttk/ttkElements.c @@ -19,6 +19,69 @@ #define DEFAULT_ARROW_SIZE "15" #define MIN_THUMB_SIZE 10 +/* + *---------------------------------------------------------------------- + * + * Helper routine for drawing a few style elements: + * + * The following function is needed when drawing the trough element + * (which is used in scrollbars, scales, and progressbars) and the + * arrow and thumb elements of a scrollbar. It draws the light or dark + * border color along the entire bottom and right edges, contrary to + * the Tk_Fill3DRectangle function, which on the windowing systems x11 + * and aqua draws the light or dark border color along the entire top + * and left edges instead. + * + * An alternative approach would be to modify the function + * Tk_3DHorizontalBevel in the file unix/tkUnix3d.c. That function is + * called in Tk_Draw3DRectangle, which in turn is invoked in + * Tk_Fill3DRectangle (both functions are implemented in the file + * generic/tk3d.c). With that approach there would be no need for the + * Fill3DRectangle function below, but it would result in some (minor) + * changes related to the appearance of most Tk and Ttk widgets on x11 + * and aqua. + */ + +#if defined(_WIN32) +#define Fill3DRectangle Tk_Fill3DRectangle +#else +static void Fill3DRectangle( + Tk_Window tkwin, /* Window for which border was allocated. */ + Drawable drawable, /* X window or pixmap in which to draw. */ + Tk_3DBorder border, /* Token for border to draw. */ + int x, int y, /* Upper-left corner of the rectangle. */ + int width, int height, /* The width and height of the rectangle. */ + int borderWidth, /* Desired width for border, in pixels. Border + * will be *inside* region. */ + int relief) /* Indicates 3D effect: TK_RELIEF_FLAT, + * TK_RELIEF_RAISED, TK_RELIEF_SUNKEN, etc. */ +{ + if (borderWidth == 1 && width >= 2 && height >= 2 && + (relief == TK_RELIEF_RAISED || relief == TK_RELIEF_SUNKEN)) { + GC flatGC = Tk_3DBorderGC(tkwin, border, TK_3D_FLAT_GC); + GC lightGC = Tk_3DBorderGC(tkwin, border, TK_3D_LIGHT_GC); + GC darkGC = Tk_3DBorderGC(tkwin, border, TK_3D_DARK_GC); + GC nGC, wGC, sGC, eGC; + int x1 = x, x2 = x + width - 1; + int y1 = y, y2 = y + height - 1; + + XFillRectangle(Tk_Display(tkwin), drawable, flatGC, + x + 1, y + 1, width - 2, height - 2); + + nGC = wGC = (relief == TK_RELIEF_RAISED ? lightGC : darkGC); + sGC = eGC = (relief == TK_RELIEF_RAISED ? darkGC : lightGC); + + XDrawLine(Tk_Display(tkwin), drawable, nGC, x1, y1, x2-1, y1); /* N */ + XDrawLine(Tk_Display(tkwin), drawable, wGC, x1, y1, x1, y2-1); /* W */ + XDrawLine(Tk_Display(tkwin), drawable, sGC, x1, y2, x2, y2); /* S */ + XDrawLine(Tk_Display(tkwin), drawable, eGC, x2, y1, x2, y2); /* E */ + } else { + Tk_Fill3DRectangle(tkwin, drawable, border, x, y, width, height, + borderWidth, relief); + } +} +#endif + /*---------------------------------------------------------------------- * +++ Null element. Does nothing; used as a stub. * Null element methods, option table and element spec are public, @@ -243,11 +306,11 @@ static void FieldElementDraw( XColor *focusColor = Tk_GetColorFromObj(tkwin, field->focusColorObj); GC focusGC = Tk_GCForColor(focusColor, d); - if (focusWidth > 1) { + if (focusWidth > 1 && b.width >= 2 && b.height >= 2) { int x1 = b.x, x2 = b.x + b.width - 1; int y1 = b.y, y2 = b.y + b.height - 1; int w = WIN32_XDRAWLINE_HACK; - GC bgGC; + GC bgGC = Tk_3DBorderGC(tkwin, border, TK_3D_FLAT_GC); /* * Draw the outer rounded rectangle @@ -266,7 +329,6 @@ static void FieldElementDraw( /* * Fill the inner rectangle */ - bgGC = Tk_3DBorderGC(tkwin, border, TK_3D_FLAT_GC); XFillRectangle(disp, d, bgGC, b.x+1, b.y+1, b.width-2, b.height-2); } else { /* @@ -384,15 +446,25 @@ static void DrawFocusRing( gc = Tk_GetGC(tkwin, GCForeground, &gcValues); if (solid) { - XRectangle rects[4] = { - {(short)b.x, (short)b.y, (unsigned short)b.width, (unsigned short)thickness}, /* N */ - {(short)b.x, (short)(b.y + b.height - thickness), (unsigned short)b.width, (unsigned short)thickness}, /* S */ - {(short)b.x, (short)(b.y + thickness), (unsigned short)thickness, (unsigned short)(b.height - 2*thickness)}, /* W */ - {(short)(b.x + b.width - thickness), (short)(b.y + thickness), /* E */ - (unsigned short)thickness, (unsigned short)(b.height - 2*thickness)} - }; - - XFillRectangles(disp, d, gc, rects, 4); + if (b.width >= 2*thickness && b.height >= 2*thickness) { + XRectangle rects[4] = { + {(short)b.x, (short)b.y, + (unsigned short)b.width, (unsigned short)thickness}, /* N */ + + {(short)b.x, (short)(b.y + b.height - thickness), + (unsigned short)b.width, (unsigned short)thickness}, /* S */ + + {(short)b.x, (short)(b.y + thickness), + (unsigned short)thickness, + (unsigned short)(b.height - 2*thickness)}, /* W */ + + {(short)(b.x + b.width - thickness), (short)(b.y + thickness), + (unsigned short)thickness, + (unsigned short)(b.height - 2*thickness)} /* E */ + }; + + XFillRectangles(disp, d, gc, rects, 4); + } } else { TkDrawDottedRect(disp, d, gc, b.x, b.y, b.width, b.height); } @@ -609,6 +681,7 @@ static void SizegripDraw( GC lightGC = Tk_3DBorderGC(tkwin, border, TK_3D_LIGHT_GC); GC darkGC = Tk_3DBorderGC(tkwin, border, TK_3D_DARK_GC); int x1 = b.x + b.width-1, y1 = b.y + b.height-1, x2 = x1, y2 = y1; + int w = WIN32_XDRAWLINE_HACK; Tk_GetPixelsFromObj(NULL, tkwin, grip->gripSizeObj, &gripSize); gripThickness = gripSize * 3 / (gripCount * 5); @@ -616,9 +689,11 @@ static void SizegripDraw( while (gripCount--) { x1 -= gripSpace; y2 -= gripSpace; for (int i = 1; i < gripThickness; i++) { - XDrawLine(Tk_Display(tkwin), d, darkGC, x1,y1, x2,y2); --x1; --y2; + XDrawLine(Tk_Display(tkwin), d, darkGC, + x1, y1, x2+w, y2-w); --x1; --y2; } - XDrawLine(Tk_Display(tkwin), d, lightGC, x1,y1, x2,y2); --x1; --y2; + XDrawLine(Tk_Display(tkwin), d, lightGC, + x1, y1, x2+w, y2-w); --x1; --y2; } } @@ -976,7 +1051,7 @@ static void ArrowElementDraw( Tk_GetPixelsFromObj(NULL, tkwin, arrow->borderWidthObj, &borderWidth); Tk_GetReliefFromObj(NULL, arrow->reliefObj, &relief); - Tk_Fill3DRectangle(tkwin, d, border, b.x, b.y, b.width, b.height, + Fill3DRectangle(tkwin, d, border, b.x, b.y, b.width, b.height, borderWidth, relief); padding.left = round(ArrowPadding.left * scalingLevel); @@ -1257,7 +1332,7 @@ static void TroughElementDraw( } } - Tk_Fill3DRectangle(tkwin, d, border, b.x, b.y, b.width, b.height, + Fill3DRectangle(tkwin, d, border, b.x, b.y, b.width, b.height, borderWidth, relief); } @@ -1332,7 +1407,7 @@ static void ThumbElementDraw( Tk_GetPixelsFromObj(NULL, tkwin, thumb->borderWidthObj, &borderWidth); Tk_GetReliefFromObj(NULL, thumb->reliefObj, &relief); - Tk_Fill3DRectangle(tkwin, d, border, b.x, b.y, b.width, b.height, + Fill3DRectangle(tkwin, d, border, b.x, b.y, b.width, b.height, borderWidth, relief); } @@ -1818,20 +1893,30 @@ static void TabElementDraw( switch (nbTabsStickBit) { default: case TTK_STICK_S: - XFillRectangle(disp, d, Tk_GCForColor(hlColor, d), - b.x + cut, b.y, b.width - 2*cut, cut); + if (b.width >= 2*cut) { + XFillRectangle(disp, d, Tk_GCForColor(hlColor, d), + b.x + cut, b.y, b.width - 2*cut, cut); + } break; case TTK_STICK_N: - XFillRectangle(disp, d, Tk_GCForColor(hlColor, d), - b.x + cut, b.y + b.height - cut, b.width - 2*cut, cut); + if (b.width >= 2*cut) { + XFillRectangle(disp, d, Tk_GCForColor(hlColor, d), + b.x + cut, b.y + b.height - cut, + b.width - 2*cut, cut); + } break; case TTK_STICK_E: - XFillRectangle(disp, d, Tk_GCForColor(hlColor, d), - b.x, b.y + cut, cut, b.height - 2*cut); + if (b.height >= 2*cut) { + XFillRectangle(disp, d, Tk_GCForColor(hlColor, d), + b.x, b.y + cut, cut, b.height - 2*cut); + } break; case TTK_STICK_W: - XFillRectangle(disp, d, Tk_GCForColor(hlColor, d), - b.x + b.width - cut, b.y + cut, cut, b.height - 2*cut); + if (b.height >= 2*cut) { + XFillRectangle(disp, d, Tk_GCForColor(hlColor, d), + b.x + b.width - cut, b.y + cut, + cut, b.height - 2*cut); + } break; } } diff --git a/generic/ttk/ttkEntry.c b/generic/ttk/ttkEntry.c index cd10a12..578e9df 100644 --- a/generic/ttk/ttkEntry.c +++ b/generic/ttk/ttkEntry.c @@ -548,8 +548,9 @@ static int RunValidationScript( Tcl_DStringValue(&script), Tcl_DStringLength(&script), TCL_EVAL_GLOBAL); Tcl_DStringFree(&script); - if (WidgetDestroyed(&entryPtr->core)) + if (WidgetDestroyed(&entryPtr->core)) { return TCL_ERROR; + } if (code != TCL_OK && code != TCL_RETURN) { Tcl_AddErrorInfo(interp, "\n\t(in "); @@ -606,8 +607,7 @@ EntryValidateChange( if ((entryPtr->entry.validateCmdObj == NULL) || (entryPtr->core.flags & VALIDATING) - || !EntryNeedsValidation(vmode, reason)) - { + || !EntryNeedsValidation(vmode, reason)) { return TCL_OK; } @@ -726,8 +726,9 @@ static void AdjustIndices(Entry *entryPtr, int index, int nChars) e->selectLast = AdjustIndex(e->selectLast, index+g, nChars); e->xscroll.first= AdjustIndex(e->xscroll.first, index+g, nChars); - if (e->selectLast <= e->selectFirst) + if (e->selectLast <= e->selectFirst) { e->selectFirst = e->selectLast = TCL_INDEX_NONE; + } } /* EntryStoreValue -- @@ -742,18 +743,21 @@ EntryStoreValue(Entry *entryPtr, const char *value) size_t numBytes = strlen(value); Tcl_Size numChars = Tcl_NumUtfChars(value, numBytes); - if (entryPtr->core.flags & VALIDATING) + if (entryPtr->core.flags & VALIDATING) { entryPtr->core.flags |= VALIDATION_SET_VALUE; + } /* Make sure all indices remain in bounds: */ - if (numChars < entryPtr->entry.numChars) + if (numChars < entryPtr->entry.numChars) { AdjustIndices(entryPtr, numChars, numChars - entryPtr->entry.numChars); + } /* Free old value: */ - if (entryPtr->entry.displayString != entryPtr->entry.string) + if (entryPtr->entry.displayString != entryPtr->entry.string) { ckfree(entryPtr->entry.displayString); + } ckfree(entryPtr->entry.string); /* Store new value: @@ -990,8 +994,9 @@ EntryCleanup(void *recordPtr) { Entry *entryPtr = (Entry *)recordPtr; - if (entryPtr->entry.textVariableTrace) + if (entryPtr->entry.textVariableTrace) { Ttk_UntraceVariable(entryPtr->entry.textVariableTrace); + } TtkFreeScrollHandle(entryPtr->entry.xscrollHandle); @@ -1000,8 +1005,9 @@ EntryCleanup(void *recordPtr) Tk_DeleteSelHandler(entryPtr->core.tkwin, XA_PRIMARY, XA_STRING); Tk_FreeTextLayout(entryPtr->entry.textLayout); - if (entryPtr->entry.displayString != entryPtr->entry.string) + if (entryPtr->entry.displayString != entryPtr->entry.string) { ckfree(entryPtr->entry.displayString); + } ckfree(entryPtr->entry.string); } @@ -1030,8 +1036,9 @@ static int EntryConfigure(Tcl_Interp *interp, void *recordPtr, int mask) /* Update derived resources: */ if (mask & TEXTVAR_CHANGED) { - if (entryPtr->entry.textVariableTrace) + if (entryPtr->entry.textVariableTrace) { Ttk_UntraceVariable(entryPtr->entry.textVariableTrace); + } entryPtr->entry.textVariableTrace = vt; } @@ -1056,8 +1063,9 @@ static int EntryConfigure(Tcl_Interp *interp, void *recordPtr, int mask) /* Recompute the displayString, in case showChar changed: */ - if (entryPtr->entry.displayString != entryPtr->entry.string) + if (entryPtr->entry.displayString != entryPtr->entry.string) { ckfree(entryPtr->entry.displayString); + } entryPtr->entry.displayString = entryPtr->entry.showCharObj @@ -1237,10 +1245,12 @@ static void EntryDisplay(void *clientData, Drawable d) /* Adjust selection range to keep in display bounds. */ if (showSelection) { - if (selFirst < leftIndex) + if (selFirst < leftIndex) { selFirst = leftIndex; - if (selLast > rightIndex) + } + if (selLast > rightIndex) { selLast = rightIndex; + } } /* Draw widget background & border @@ -1260,14 +1270,16 @@ static void EntryDisplay(void *clientData, Drawable d) if (selBorder) { int selWidth; int textareaEnd = textarea.x + textarea.width; - if (selEndX > textareaEnd) + if (selEndX > textareaEnd) { selEndX = textareaEnd; + } selWidth = selEndX - selStartX + 2 * borderWidth; - if (selWidth > 0) + if (selWidth > 0) { Tk_Fill3DRectangle(tkwin, d, selBorder, selStartX - borderWidth, entryPtr->entry.layoutY - borderWidth, selWidth, entryPtr->entry.layoutHeight + 2*borderWidth, borderWidth, TK_RELIEF_RAISED); + } } } @@ -1430,7 +1442,7 @@ EntryIndex( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "selection isn't in widget %s", Tk_PathName(entryPtr->core.tkwin))); - Tcl_SetErrorCode(interp, "TTK", "ENTRY", "NO_SELECTION", NULL); + Tcl_SetErrorCode(interp, "TTK", "ENTRY", "NO_SELECTION", (char *)NULL); return TCL_ERROR; } if (strncmp(string, "sel.first", length) == 0) { @@ -1478,7 +1490,7 @@ EntryIndex( badIndex: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad entry index \"%s\"", string)); - Tcl_SetErrorCode(interp, "TTK", "ENTRY", "INDEX", NULL); + Tcl_SetErrorCode(interp, "TTK", "ENTRY", "INDEX", (char *)NULL); return TCL_ERROR; } @@ -1725,8 +1737,9 @@ static int EntryValidateCommand( code = EntryRevalidate(interp, entryPtr, VALIDATE_FORCED); - if (code == TCL_ERROR) + if (code == TCL_ERROR) { return code; + } Tcl_SetObjResult(interp, Tcl_NewBooleanObj(code == TCL_OK)); return TCL_OK; @@ -1841,8 +1854,9 @@ ComboboxConfigure(Tcl_Interp *interp, void *recordPtr, int mask) /* Make sure -values is a valid list: */ - if (Tcl_ListObjLength(interp,cbPtr->combobox.valuesObj,&unused) != TCL_OK) + if (Tcl_ListObjLength(interp,cbPtr->combobox.valuesObj,&unused) != TCL_OK) { return TCL_ERROR; + } return EntryConfigure(interp, recordPtr, mask); } @@ -1894,14 +1908,14 @@ static int ComboboxCurrentCommand( if (idx < 0 || idx >= nValues) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "index \"%s\" out of range", Tcl_GetString(objv[2]))); - Tcl_SetErrorCode(interp, "TTK", "COMBOBOX", "IDX_RANGE", NULL); + Tcl_SetErrorCode(interp, "TTK", "COMBOBOX", "IDX_RANGE", (char *)NULL); return TCL_ERROR; } currentIndex = idx; } else { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad index \"%s\"", Tcl_GetString(objv[2]))); - Tcl_SetErrorCode(interp, "TTK", "COMBOBOX", "IDX_VALUE", NULL); + Tcl_SetErrorCode(interp, "TTK", "COMBOBOX", "IDX_VALUE", (char *)NULL); return TCL_ERROR; } @@ -2026,8 +2040,9 @@ SpinboxConfigure(Tcl_Interp *interp, void *recordPtr, int mask) /* Make sure -values is a valid list: */ - if (Tcl_ListObjLength(interp,sb->spinbox.valuesObj,&unused) != TCL_OK) + if (Tcl_ListObjLength(interp,sb->spinbox.valuesObj,&unused) != TCL_OK) { return TCL_ERROR; + } return EntryConfigure(interp, recordPtr, mask); } @@ -2103,8 +2118,9 @@ static void TextareaElementSize( Tk_GetFontMetrics(font, &fm); Tcl_GetIntFromObj(NULL, textarea->widthObj, &prefWidth); - if (prefWidth <= 0) + if (prefWidth <= 0) { prefWidth = 1; + } *heightPtr = fm.linespace; *widthPtr = prefWidth * avgWidth; diff --git a/generic/ttk/ttkFrame.c b/generic/ttk/ttkFrame.c index b4c6e35..a1a37b2 100644 --- a/generic/ttk/ttkFrame.c +++ b/generic/ttk/ttkFrame.c @@ -211,7 +211,7 @@ error: if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "Bad label anchor specification %s", Tcl_GetString(objPtr))); - Tcl_SetErrorCode(interp, "TTK", "LABEL", "ANCHOR", NULL); + Tcl_SetErrorCode(interp, "TTK", "LABEL", "ANCHOR", (char *)NULL); } return TCL_ERROR; } @@ -303,10 +303,10 @@ static void LabelframeStyleOptions(Labelframe *lf, LabelframeStyle *style) } else { if (style->labelAnchor & (TTK_PACK_TOP|TTK_PACK_BOTTOM)) { style->labelMargins = - Ttk_MakePadding(DEFAULT_LABELINSET,0,DEFAULT_LABELINSET,0); + Ttk_MakePadding(DEFAULT_LABELINSET, 0, DEFAULT_LABELINSET, 0); } else { style->labelMargins = - Ttk_MakePadding(0,DEFAULT_LABELINSET,0,DEFAULT_LABELINSET); + Ttk_MakePadding(0, DEFAULT_LABELINSET, 0, DEFAULT_LABELINSET); } } if ((objPtr = Ttk_QueryOption(layout,"-labeloutside", 0)) != NULL) { @@ -366,10 +366,10 @@ static int LabelframeSize( labelHeight += Ttk_PaddingHeight(style.labelMargins); switch (LabelAnchorSide(style.labelAnchor)) { - case TTK_SIDE_LEFT: margins.left += labelWidth; break; - case TTK_SIDE_RIGHT: margins.right += labelWidth; break; - case TTK_SIDE_TOP: margins.top += labelHeight; break; - case TTK_SIDE_BOTTOM: margins.bottom += labelHeight; break; + case TTK_SIDE_LEFT: margins.left += (short)labelWidth; break; + case TTK_SIDE_RIGHT: margins.right += (short)labelWidth; break; + case TTK_SIDE_TOP: margins.top += (short)labelHeight; break; + case TTK_SIDE_BOTTOM: margins.bottom += (short)labelHeight; break; } Ttk_SetMargins(corePtr->tkwin,margins); diff --git a/generic/ttk/ttkImage.c b/generic/ttk/ttkImage.c index d46b420..357caab 100644 --- a/generic/ttk/ttkImage.c +++ b/generic/ttk/ttkImage.c @@ -100,7 +100,7 @@ TtkGetImageSpecEx(Tcl_Interp *interp, Tk_Window tkwin, Tcl_Obj *objPtr, Tcl_SetObjResult(interp, Tcl_NewStringObj( "image specification must contain an odd number of elements", -1)); - Tcl_SetErrorCode(interp, "TTK", "IMAGE", "SPEC", NULL); + Tcl_SetErrorCode(interp, "TTK", "IMAGE", "SPEC", (char *)NULL); } goto error; } @@ -222,8 +222,9 @@ static void Ttk_Fill( int db = dst.y + dst.height; int x,y; - if (!(src.width && src.height && dst.width && dst.height)) + if (!(src.width && src.height && dst.width && dst.height)) { return; + } for (x = dst.x; x < dr; x += src.width) { int cw = MIN(src.width, dr - x); @@ -380,7 +381,7 @@ Ttk_CreateImageElement( if (objc + 1 < 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "Must supply a base image", -1)); - Tcl_SetErrorCode(interp, "TTK", "IMAGE", "BASE", NULL); + Tcl_SetErrorCode(interp, "TTK", "IMAGE", "BASE", (char *)NULL); return TCL_ERROR; } @@ -405,7 +406,7 @@ Ttk_CreateImageElement( if (i == objc - 1) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "Value for %s missing", Tcl_GetString(objv[i]))); - Tcl_SetErrorCode(interp, "TTK", "IMAGE", "VALUE", NULL); + Tcl_SetErrorCode(interp, "TTK", "IMAGE", "VALUE", (char *)NULL); goto error; } diff --git a/generic/ttk/ttkInit.c b/generic/ttk/ttkInit.c index 38bbbaa..96c2766 100644 --- a/generic/ttk/ttkInit.c +++ b/generic/ttk/ttkInit.c @@ -201,6 +201,7 @@ MODULE_SCOPE void TtkProgressbar_Init(Tcl_Interp *); MODULE_SCOPE void TtkScale_Init(Tcl_Interp *); MODULE_SCOPE void TtkScrollbar_Init(Tcl_Interp *); MODULE_SCOPE void TtkSeparator_Init(Tcl_Interp *); +MODULE_SCOPE void TtkToggleswitch_Init(Tcl_Interp *); MODULE_SCOPE void TtkTreeview_Init(Tcl_Interp *); #ifdef TTK_SQUARE_WIDGET @@ -218,6 +219,7 @@ static void RegisterWidgets(Tcl_Interp *interp) TtkScale_Init(interp); TtkScrollbar_Init(interp); TtkSeparator_Init(interp); + TtkToggleswitch_Init(interp); TtkTreeview_Init(interp); #ifdef TTK_SQUARE_WIDGET TtkSquareWidget_Init(interp); diff --git a/generic/ttk/ttkLabel.c b/generic/ttk/ttkLabel.c index a59f1fe..85629bf 100644 --- a/generic/ttk/ttkLabel.c +++ b/generic/ttk/ttkLabel.c @@ -104,8 +104,9 @@ static int TextReqWidth(TextElement *text) int avgWidth = Tk_TextWidth(text->tkfont, "0", 1); if (reqWidth <= 0) { int specWidth = avgWidth * -reqWidth; - if (specWidth > text->width) + if (specWidth > text->width) { return specWidth; + } } else { return avgWidth * reqWidth; } @@ -209,8 +210,9 @@ static void TextElementSize( { TextElement *text = (TextElement *)elementRecord; - if (!TextSetup(text, tkwin)) + if (!TextSetup(text, tkwin)) { return; + } *heightPtr = text->height; *widthPtr = TextReqWidth(text); @@ -270,8 +272,9 @@ static void cTextElementSize( { TextElement *text = (TextElement *)elementRecord; - if (!cTextSetup(text, tkwin)) + if (!cTextSetup(text, tkwin)) { return; + } *heightPtr = text->height; *widthPtr = TextReqWidth(text); @@ -580,8 +583,9 @@ static void LabelSetup( c->compound = TTK_COMPOUND_TEXT; } } - if (c->compound != TTK_COMPOUND_IMAGE) + if (c->compound != TTK_COMPOUND_IMAGE) { TextSetup(&c->text, tkwin); + } /* * ASSERT: @@ -623,10 +627,12 @@ static void LabelSetup( static void LabelCleanup(LabelElement *c) { - if (c->compound != TTK_COMPOUND_TEXT) + if (c->compound != TTK_COMPOUND_TEXT) { ImageCleanup(&c->image); - if (c->compound != TTK_COMPOUND_IMAGE) + } + if (c->compound != TTK_COMPOUND_IMAGE) { TextCleanup(&c->text); + } } static void LabelElementSize( @@ -646,8 +652,9 @@ static void LabelElementSize( /* Requested width based on -width option, not actual text width: */ - if (label->compound != TTK_COMPOUND_IMAGE) + if (label->compound != TTK_COMPOUND_IMAGE) { textReqWidth = TextReqWidth(&label->text); + } switch (label->compound) { diff --git a/generic/ttk/ttkLayout.c b/generic/ttk/ttkLayout.c index 48cf615..b77db39 100644 --- a/generic/ttk/ttkLayout.c +++ b/generic/ttk/ttkLayout.c @@ -335,7 +335,7 @@ int Ttk_GetPaddingFromObj( if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "Wrong #elements in padding spec", -1)); - Tcl_SetErrorCode(interp, "TTK", "VALUE", "PADDING", NULL); + Tcl_SetErrorCode(interp, "TTK", "VALUE", "PADDING", (char *)NULL); } goto error; } @@ -374,7 +374,7 @@ int Ttk_GetBorderFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Ttk_Padding *pad) if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "Wrong #elements in padding spec", -1)); - Tcl_SetErrorCode(interp, "TTK", "VALUE", "BORDER", NULL); + Tcl_SetErrorCode(interp, "TTK", "VALUE", "BORDER", (char *)NULL); } goto error; } @@ -489,7 +489,7 @@ int Ttk_GetStickyFromObj( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "Bad -sticky specification %s", Tcl_GetString(objPtr))); - Tcl_SetErrorCode(interp, "TTK", "VALUE", "STICKY", NULL); + Tcl_SetErrorCode(interp, "TTK", "VALUE", "STICKY", (char *)NULL); } return TCL_ERROR; } @@ -625,8 +625,9 @@ Ttk_LayoutTemplate Ttk_ParseLayoutTemplate(Tcl_Interp *interp, Tcl_Obj *objPtr) Tcl_Obj **objv; Ttk_TemplateNode *head = 0, *tail = 0; - if (Tcl_ListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) + if (Tcl_ListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) { return 0; + } while (i < objc) { const char *elementName = Tcl_GetString(objv[i]); @@ -641,8 +642,9 @@ Ttk_LayoutTemplate Ttk_ParseLayoutTemplate(Tcl_Interp *interp, Tcl_Obj *objPtr) const char *optName = Tcl_GetString(objv[i]); int option, value; - if (optName[0] != '-') + if (optName[0] != '-') { break; + } if (Tcl_GetIndexFromObjStruct(interp, objv[i], optStrings, sizeof(char *), "option", 0, &option) @@ -655,41 +657,47 @@ Ttk_LayoutTemplate Ttk_ParseLayoutTemplate(Tcl_Interp *interp, Tcl_Obj *objPtr) Tcl_SetObjResult(interp, Tcl_ObjPrintf( "Missing value for option %s", Tcl_GetString(objv[i-1]))); - Tcl_SetErrorCode(interp, "TTK", "VALUE", "LAYOUT", NULL); + Tcl_SetErrorCode(interp, "TTK", "VALUE", "LAYOUT", (char *)NULL); goto error; } switch (option) { case OP_SIDE: /* <<NOTE-PACKSIDE>> */ if (Tcl_GetIndexFromObjStruct(interp, objv[i], packSideStrings, - sizeof(char *), "side", 0, &value) != TCL_OK) - { + sizeof(char *), "side", 0, &value) != TCL_OK) { goto error; } flags |= (TTK_PACK_LEFT << value); break; case OP_STICKY: - if (Ttk_GetStickyFromObj(interp,objv[i],&sticky) != TCL_OK) + if (Ttk_GetStickyFromObj(interp,objv[i],&sticky) != TCL_OK) { goto error; + } break; case OP_EXPAND: - if (Tcl_GetBooleanFromObj(interp,objv[i],&value) != TCL_OK) + if (Tcl_GetBooleanFromObj(interp,objv[i],&value) != TCL_OK) { goto error; - if (value) + } + if (value) { flags |= TTK_EXPAND; + } break; case OP_BORDER: - if (Tcl_GetBooleanFromObj(interp,objv[i],&value) != TCL_OK) + if (Tcl_GetBooleanFromObj(interp,objv[i],&value) != TCL_OK) { goto error; - if (value) + } + if (value) { flags |= TTK_BORDER; + } break; case OP_UNIT: - if (Tcl_GetBooleanFromObj(interp,objv[i],&value) != TCL_OK) + if (Tcl_GetBooleanFromObj(interp,objv[i],&value) != TCL_OK) { goto error; - if (value) + } + if (value) { flags |= TTK_UNIT; + } break; case OP_CHILDREN: childSpec = objv[i]; @@ -711,7 +719,7 @@ Ttk_LayoutTemplate Ttk_ParseLayoutTemplate(Tcl_Interp *interp, Tcl_Obj *objPtr) tail->child = Ttk_ParseLayoutTemplate(interp, childSpec); if (!tail->child) { Tcl_SetObjResult(interp, Tcl_ObjPrintf("Invalid -children value")); - Tcl_SetErrorCode(interp, "TTK", "VALUE", "CHILDREN", NULL); + Tcl_SetErrorCode(interp, "TTK", "VALUE", "CHILDREN", (char *)NULL); goto error; } } @@ -890,7 +898,7 @@ Ttk_Layout Ttk_CreateLayout( if (!layoutTemplate) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "Layout %s not found", styleName)); - Tcl_SetErrorCode(interp, "TTK", "LOOKUP", "LAYOUT", styleName, NULL); + Tcl_SetErrorCode(interp, "TTK", "LOOKUP", "LAYOUT", styleName, (char *)NULL); return 0; } @@ -931,7 +939,7 @@ Ttk_CreateSublayout( if (!layoutTemplate) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "Layout %s not found", styleName)); - Tcl_SetErrorCode(interp, "TTK", "LOOKUP", "LAYOUT", styleName, NULL); + Tcl_SetErrorCode(interp, "TTK", "LOOKUP", "LAYOUT", styleName, (char *)NULL); return 0; } @@ -1121,19 +1129,22 @@ static void Ttk_DrawNodeList( int border = node->flags & TTK_BORDER; int substate = state; - if (node->flags & TTK_UNIT) + if (node->flags & TTK_UNIT) { substate |= node->state; + } - if (node->child && border) + if (node->child && border) { Ttk_DrawNodeList(layout, substate, node->child, d); + } Ttk_DrawElement( node->eclass, layout->style,layout->recordPtr,layout->optionTable,layout->tkwin, d, node->parcel, state | node->state); - if (node->child && !border) + if (node->child && !border) { Ttk_DrawNodeList(layout, substate, node->child, d); + } } } @@ -1194,13 +1205,15 @@ static Ttk_Element FindNode(Ttk_Element node, const char *nodeName) { for (; node ; node = node->next) { - if (!strcmp(tail(Ttk_ElementName(node)), nodeName)) + if (!strcmp(tail(Ttk_ElementName(node)), nodeName)) { return node; + } if (node->child) { Ttk_Element childNode = FindNode(node->child, nodeName); - if (childNode) + if (childNode) { return childNode; + } } } return 0; diff --git a/generic/ttk/ttkManager.c b/generic/ttk/ttkManager.c index 8ce7b3d..e660538 100644 --- a/generic/ttk/ttkManager.c +++ b/generic/ttk/ttkManager.c @@ -429,8 +429,9 @@ Tcl_Size Ttk_ContentIndex(Ttk_Manager *mgr, Tk_Window window) { Tcl_Size index; for (index = 0; index < mgr->nContent; ++index) - if (mgr->content[index]->window == window) + if (mgr->content[index]->window == window) { return index; + } return -1; } @@ -465,7 +466,7 @@ int Ttk_GetContentIndexFromObj( if (index < 0 || (index - !!lastOK) >= mgr->nContent) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "Managed window index \"%s\" out of bounds", Tcl_GetString(objPtr))); - Tcl_SetErrorCode(interp, "TTK", "MANAGED", "INDEX", NULL); + Tcl_SetErrorCode(interp, "TTK", "MANAGED", "INDEX", (char *)NULL); return TCL_ERROR; } *indexPtr = index; @@ -481,7 +482,7 @@ int Ttk_GetContentIndexFromObj( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s is not managed by %s", string, Tk_PathName(mgr->window))); - Tcl_SetErrorCode(interp, "TTK", "MANAGED", "MANAGER", NULL); + Tcl_SetErrorCode(interp, "TTK", "MANAGED", "MANAGER", (char *)NULL); return TCL_ERROR; } *indexPtr = index; @@ -490,7 +491,7 @@ int Ttk_GetContentIndexFromObj( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "Invalid managed window specification %s", string)); - Tcl_SetErrorCode(interp, "TTK", "MANAGED", "SPEC", NULL); + Tcl_SetErrorCode(interp, "TTK", "MANAGED", "SPEC", (char *)NULL); return TCL_ERROR; } @@ -551,7 +552,7 @@ int Ttk_Maintainable(Tcl_Interp *interp, Tk_Window window, Tk_Window container) badWindow: Tcl_SetObjResult(interp, Tcl_ObjPrintf("cannot add \"%s\" as content of \"%s\"", Tk_PathName(window), Tk_PathName(container))); - Tcl_SetErrorCode(interp, "TTK", "GEOMETRY", "MAINTAINABLE", NULL); + Tcl_SetErrorCode(interp, "TTK", "GEOMETRY", "MAINTAINABLE", (char *)NULL); return 0; } diff --git a/generic/ttk/ttkNotebook.c b/generic/ttk/ttkNotebook.c index 6b730b9..649964a 100644 --- a/generic/ttk/ttkNotebook.c +++ b/generic/ttk/ttkNotebook.c @@ -227,21 +227,18 @@ static int ConfigureTab( int mask = 0; if (Tk_SetOptions(interp, tab, nb->notebook.paneOptionTable, - objc, objv, window, &savedOptions, &mask) != TCL_OK) - { + objc, objv, window, &savedOptions, &mask) != TCL_OK) { return TCL_ERROR; } /* Check options: * @@@ TODO: validate -image option. */ - if (Ttk_GetStickyFromObj(interp, tab->stickyObj, &sticky) != TCL_OK) - { + if (Ttk_GetStickyFromObj(interp, tab->stickyObj, &sticky) != TCL_OK) { goto error; } if (Ttk_GetPaddingFromObj(interp, window, tab->paddingObj, &padding) - != TCL_OK) - { + != TCL_OK) { goto error; } @@ -268,9 +265,8 @@ static Tcl_Size IdentifyTab(Notebook *nb, int x, int y) Tcl_Size index; for (index = 0; index < Ttk_NumberContent(nb->notebook.mgr); ++index) { Tab *tab = (Tab *)Ttk_ContentData(nb->notebook.mgr,index); - if ( tab->state != TAB_STATE_HIDDEN - && Ttk_BoxContains(tab->parcel, x,y)) - { + if (tab->state != TAB_STATE_HIDDEN + && Ttk_BoxContains(tab->parcel, x,y)) { return index; } } @@ -423,10 +419,12 @@ static int NotebookSize(void *clientData, int *widthPtr, int *heightPtr) */ Tk_GetPixelsFromObj(NULL, nbwin, nb->notebook.widthObj, &reqWidth); Tk_GetPixelsFromObj(NULL, nbwin, nb->notebook.heightObj, &reqHeight); - if (reqWidth > 0) + if (reqWidth > 0) { clientWidth = reqWidth; - if (reqHeight > 0) + } + if (reqHeight > 0) { clientHeight = reqHeight; + } /* Tab row: */ @@ -754,7 +752,7 @@ static int AddTab( if (Ttk_ContentIndex(nb->notebook.mgr, window) >= 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf("%s already added", Tk_PathName(window))); - Tcl_SetErrorCode(interp, "TTK", "NOTEBOOK", "PRESENT", NULL); + Tcl_SetErrorCode(interp, "TTK", "NOTEBOOK", "PRESENT", (char *)NULL); return TCL_ERROR; } #endif @@ -870,7 +868,7 @@ static int FindTabIndex( if (*index_rtn == Ttk_NumberContent(nb->notebook.mgr)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "Invalid tab specification %s", string)); - Tcl_SetErrorCode(interp, "TTK", "NOTEBOOK", "SPEC", NULL); + Tcl_SetErrorCode(interp, "TTK", "NOTEBOOK", "SPEC", (char *)NULL); return TCL_ERROR; } @@ -891,14 +889,14 @@ static int GetTabIndex( if (status == TCL_OK && *index_rtn >= Ttk_NumberContent(nb->notebook.mgr)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "Tab index \"%s\" out of bounds", Tcl_GetString(objPtr))); - Tcl_SetErrorCode(interp, "TTK", "NOTEBOOK", "INDEX", NULL); + Tcl_SetErrorCode(interp, "TTK", "NOTEBOOK", "INDEX", (char *)NULL); return TCL_ERROR; } if (status == TCL_OK && *index_rtn < 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "Tab '%s' not found", Tcl_GetString(objPtr))); - Tcl_SetErrorCode(interp, "TTK", "NOTEBOOK", "TAB", NULL); + Tcl_SetErrorCode(interp, "TTK", "NOTEBOOK", "TAB", (char *)NULL); status = TCL_ERROR; } return status; @@ -1309,8 +1307,9 @@ static void NotebookCleanup(void *recordPtr) Notebook *nb = (Notebook *)recordPtr; Ttk_DeleteManager(nb->notebook.mgr); - if (nb->notebook.tabLayout) + if (nb->notebook.tabLayout) { Ttk_FreeLayout(nb->notebook.tabLayout); + } } static int NotebookConfigure(Tcl_Interp *interp, void *clientData, int mask) diff --git a/generic/ttk/ttkPanedwindow.c b/generic/ttk/ttkPanedwindow.c index 15f6d59..43271e5 100644 --- a/generic/ttk/ttkPanedwindow.c +++ b/generic/ttk/ttkPanedwindow.c @@ -158,7 +158,7 @@ static int ConfigurePane( if (pane->weight < 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "-weight must be non-negative", -1)); - Tcl_SetErrorCode(interp, "TTK", "PANE", "WEIGHT", NULL); + Tcl_SetErrorCode(interp, "TTK", "PANE", "WEIGHT", (char *)NULL); goto error; } @@ -192,12 +192,14 @@ static int ShoveUp(Paned *pw, int i, int pos) int sashThickness = pw->paned.sashThickness; if (i == 0) { - if (pos < 0) + if (pos < 0) { pos = 0; + } } else { Pane *prevPane = (Pane *)Ttk_ContentData(pw->paned.mgr, i-1); - if (pos < prevPane->sashPos + sashThickness) + if (pos < prevPane->sashPos + sashThickness) { pos = ShoveUp(pw, i-1, pos - sashThickness) + sashThickness; + } } return pane->sashPos = pos; } @@ -215,8 +217,9 @@ static int ShoveDown(Paned *pw, Tcl_Size i, int pos) pos = pane->sashPos; /* Sentinel value == container window size */ } else { Pane *nextPane = (Pane *)Ttk_ContentData(pw->paned.mgr,i+1); - if (pos + sashThickness > nextPane->sashPos) + if (pos + sashThickness > nextPane->sashPos) { pos = ShoveDown(pw, i+1, pos + sashThickness) - sashThickness; + } } return pane->sashPos = pos; } @@ -241,8 +244,9 @@ static int PanedSize(void *recordPtr, int *widthPtr, int *heightPtr) Pane *pane = (Pane *)Ttk_ContentData(pw->paned.mgr, index); Tk_Window window = Ttk_ContentWindow(pw->paned.mgr, index); - if (height < Tk_ReqHeight(window)) + if (height < Tk_ReqHeight(window)) { height = Tk_ReqHeight(window); + } width += pane->reqSize; } width += nSashes * sashThickness; @@ -251,8 +255,9 @@ static int PanedSize(void *recordPtr, int *widthPtr, int *heightPtr) Pane *pane = (Pane *)Ttk_ContentData(pw->paned.mgr, index); Tk_Window window = Ttk_ContentWindow(pw->paned.mgr, index); - if (width < Tk_ReqWidth(window)) + if (width < Tk_ReqWidth(window)) { width = Tk_ReqWidth(window); + } height += pane->reqSize; } height += nSashes * sashThickness; @@ -310,8 +315,9 @@ static void PlaceSashes(Paned *pw, int width, int height) int reqSize = 0, totalWeight = 0; int difference, delta, remainder, pos, i; - if (nPanes == 0) + if (nPanes == 0) { return; + } /* Compute total required size and total available weight: */ @@ -344,13 +350,15 @@ static void PlaceSashes(Paned *pw, int width, int height) int weight = pane->weight * (pane->reqSize != 0); int size = pane->reqSize + delta * weight; - if (weight > remainder) + if (weight > remainder) { weight = remainder; + } remainder -= weight; size += weight; - if (size < 0) + if (size < 0) { size = 0; + } pane->sashPos = (pos += size); pos += sashThickness; @@ -422,7 +430,7 @@ static int AddPane( if (Ttk_ContentIndex(pw->paned.mgr, window) >= 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s already added", Tk_PathName(window))); - Tcl_SetErrorCode(interp, "TTK", "PANE", "PRESENT", NULL); + Tcl_SetErrorCode(interp, "TTK", "PANE", "PRESENT", (char *)NULL); return TCL_ERROR; } @@ -512,8 +520,9 @@ static void PanedCleanup(void *recordPtr) { Paned *pw = (Paned *)recordPtr; - if (pw->paned.sashLayout) + if (pw->paned.sashLayout) { Ttk_FreeLayout(pw->paned.sashLayout); + } Tk_DeleteEventHandler(pw->core.tkwin, PanedEventMask, PanedEventProc, recordPtr); Ttk_DeleteManager(pw->paned.mgr); @@ -563,8 +572,9 @@ static Ttk_Layout PanedGetLayout( Ttk_LayoutSize(sashLayout, 0, &sashWidth, &sashHeight); pw->paned.sashThickness = horizontal ? sashWidth : sashHeight; - if (pw->paned.sashLayout) + if (pw->paned.sashLayout) { Ttk_FreeLayout(pw->paned.sashLayout); + } pw->paned.sashLayout = sashLayout; } else { Ttk_FreeLayout(panedLayout); @@ -677,8 +687,9 @@ static int PanedInsertCommand( return AddPane(interp, pw, destIndex, window, objc-4, objv+4); } /* else -- move existing content: */ - if (destIndex >= nContent) + if (destIndex >= nContent) { destIndex = nContent - 1; + } Ttk_ReorderContent(pw->paned.mgr, srcIndex, destIndex); return objc == 4 ? TCL_OK : @@ -852,7 +863,7 @@ static int PanedSashposCommand( if (sashIndex < 0 || sashIndex >= Ttk_NumberContent(pw->paned.mgr) - 1) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "sash index %" TCL_LL_MODIFIER "d out of range", sashIndex)); - Tcl_SetErrorCode(interp, "TTK", "PANE", "SASH_INDEX", NULL); + Tcl_SetErrorCode(interp, "TTK", "PANE", "SASH_INDEX", (char *)NULL); return TCL_ERROR; } diff --git a/generic/ttk/ttkProgress.c b/generic/ttk/ttkProgress.c index af8c527..74cced3 100644 --- a/generic/ttk/ttkProgress.c +++ b/generic/ttk/ttkProgress.c @@ -220,10 +220,12 @@ static void ProgressbarInitialize( static void ProgressbarCleanup(void *recordPtr) { Progressbar *pb = (Progressbar *)recordPtr; - if (pb->progress.variableTrace) + if (pb->progress.variableTrace) { Ttk_UntraceVariable(pb->progress.variableTrace); - if (pb->progress.timer) + } + if (pb->progress.timer) { Tcl_DeleteTimerHandler(pb->progress.timer); + } } /* @@ -405,10 +407,12 @@ static Ttk_Layout ProgressbarGetLayout( if (layout) { Tcl_Obj *periodObj = Ttk_QueryOption(layout, "-period", 0); Tcl_Obj *maxPhaseObj = Ttk_QueryOption(layout, "-maxphase", 0); - if (periodObj) + if (periodObj) { Tcl_GetIntFromObj(NULL, periodObj, &pb->progress.period); - if (maxPhaseObj) + } + if (maxPhaseObj) { Tcl_GetIntFromObj(NULL, maxPhaseObj, &pb->progress.maxPhase); + } } return layout; diff --git a/generic/ttk/ttkScale.c b/generic/ttk/ttkScale.c index e318600..36e6946 100644 --- a/generic/ttk/ttkScale.c +++ b/generic/ttk/ttkScale.c @@ -271,8 +271,9 @@ ScaleGetCommand( Tcl_SetObjResult(interp, scalePtr->scale.valueObj); } else if (objc == 4) { r = Tcl_GetIntFromObj(interp, objv[2], &x); - if (r == TCL_OK) + if (r == TCL_OK) { r = Tcl_GetIntFromObj(interp, objv[3], &y); + } if (r == TCL_OK) { value = PointToValue(scalePtr, x, y); Tcl_SetObjResult(interp, Tcl_NewDoubleObj(value)); @@ -440,14 +441,27 @@ static double PointToValue(Scale *scalePtr, int x, int y) { Ttk_Box troughBox = TroughRange(scalePtr); - double from = 0, to = 1, fraction; + double value = 0, from = 0, to = 1, fraction; + Tcl_GetDoubleFromObj(NULL, scalePtr->scale.valueObj, &value); Tcl_GetDoubleFromObj(NULL, scalePtr->scale.fromObj, &from); Tcl_GetDoubleFromObj(NULL, scalePtr->scale.toObj, &to); if (scalePtr->scale.orient == TTK_ORIENT_HORIZONTAL) { + /* + * Bug d25b721f: drag when trough not shown due to missing display place + */ + if (troughBox.width <= 0) { + return value; + } fraction = (double)(x - troughBox.x) / (double)troughBox.width; } else { + /* + * Bug d25b721f: drag when trough not shown due to missing display place + */ + if (troughBox.height <= 0) { + return value; + } fraction = (double)(y - troughBox.y) / (double)troughBox.height; } diff --git a/generic/ttk/ttkScroll.c b/generic/ttk/ttkScroll.c index 61b3273..c1c5d25 100644 --- a/generic/ttk/ttkScroll.c +++ b/generic/ttk/ttkScroll.c @@ -258,12 +258,15 @@ void TtkScrollTo(ScrollHandle h, int newFirst, int updateScrollInfo) TtkUpdateScrollInfo(h); } - if (newFirst >= s->total) + if (newFirst >= s->total) { newFirst = s->total - 1; - if (newFirst > s->first && s->last >= s->total) /* don't scroll past end */ + } + if (newFirst > s->first && s->last >= s->total) {/* don't scroll past end */ newFirst = s->first; - if (newFirst < 0) + } + if (newFirst < 0) { newFirst = 0; + } if (newFirst != s->first) { s->first = newFirst; diff --git a/generic/ttk/ttkSquare.c b/generic/ttk/ttkSquare.c index d0d25b1..c9500e0 100644 --- a/generic/ttk/ttkSquare.c +++ b/generic/ttk/ttkSquare.c @@ -114,8 +114,9 @@ SquareDoLayout(void *clientData) Ttk_Box b; b = Ttk_ElementParcel(squareNode); - if (squarePtr->square.anchorObj != NULL) + if (squarePtr->square.anchorObj != NULL) { Tk_GetAnchorFromObj(NULL, squarePtr->square.anchorObj, &anchor); + } b = Ttk_AnchorBox(winBox, b.width, b.height, anchor); Ttk_PlaceElement(corePtr->layout, squareNode, b); diff --git a/generic/ttk/ttkState.c b/generic/ttk/ttkState.c index 005cd48..4024f0b 100644 --- a/generic/ttk/ttkState.c +++ b/generic/ttk/ttkState.c @@ -79,8 +79,9 @@ static int StateSpecSetFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr) unsigned int onbits = 0, offbits = 0; status = Tcl_ListObjGetElements(interp, objPtr, &objc, &objv); - if (status != TCL_OK) + if (status != TCL_OK) { return status; + } for (i = 0; i < objc; ++i) { const char *stateName = Tcl_GetString(objv[i]); @@ -94,15 +95,16 @@ static int StateSpecSetFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr) } for (j = 0; stateNames[j].value; ++j) { - if (strcmp(stateName, stateNames[j].name) == 0) + if (strcmp(stateName, stateNames[j].name) == 0) { break; + } } if (stateNames[j].value == 0) { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "Invalid state name %s", stateName)); - Tcl_SetErrorCode(interp, "TTK", "VALUE", "STATE", NULL); + Tcl_SetErrorCode(interp, "TTK", "VALUE", "STATE", (char *)NULL); } return TCL_ERROR; } @@ -185,8 +187,9 @@ int Ttk_GetStateSpecFromObj( { if (objPtr->typePtr != &StateSpecObjType.objType) { int status = StateSpecSetFromAny(interp, objPtr); - if (status != TCL_OK) + if (status != TCL_OK) { return status; + } } spec->onbits = objPtr->internalRep.wideValue >> 32; @@ -212,20 +215,23 @@ Tcl_Obj *Ttk_StateMapLookup( int status; status = Tcl_ListObjGetElements(interp, map, &nSpecs, &specs); - if (status != TCL_OK) + if (status != TCL_OK) { return NULL; + } for (j = 0; j < nSpecs; j += 2) { Ttk_StateSpec spec; status = Ttk_GetStateSpecFromObj(interp, specs[j], &spec); - if (status != TCL_OK) + if (status != TCL_OK) { return NULL; - if (Ttk_StateMatches(state, &spec)) + } + if (Ttk_StateMatches(state, &spec)) { return specs[j+1]; + } } if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj("No match in state map", -1)); - Tcl_SetErrorCode(interp, "TTK", "STATE", "UNMATCHED", NULL); + Tcl_SetErrorCode(interp, "TTK", "STATE", "UNMATCHED", (char *)NULL); } return NULL; } @@ -244,22 +250,24 @@ Ttk_StateMap Ttk_GetStateMapFromObj( int status; status = Tcl_ListObjGetElements(interp, mapObj, &nSpecs, &specs); - if (status != TCL_OK) + if (status != TCL_OK) { return NULL; + } if (nSpecs % 2 != 0) { if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "State map must have an even number of elements", -1)); - Tcl_SetErrorCode(interp, "TTK", "VALUE", "STATEMAP", NULL); + Tcl_SetErrorCode(interp, "TTK", "VALUE", "STATEMAP", (char *)NULL); } return 0; } for (j = 0; j < nSpecs; j += 2) { Ttk_StateSpec spec; - if (Ttk_GetStateSpecFromObj(interp, specs[j], &spec) != TCL_OK) + if (Ttk_GetStateSpecFromObj(interp, specs[j], &spec) != TCL_OK) { return NULL; + } } return mapObj; diff --git a/generic/ttk/ttkStubInit.c b/generic/ttk/ttkStubInit.c index 9d7d4fc..4dea92d 100644 --- a/generic/ttk/ttkStubInit.c +++ b/generic/ttk/ttkStubInit.c @@ -8,6 +8,11 @@ MODULE_SCOPE const TtkStubs ttkStubs; + +#ifdef TK_NO_DEPRECATED +# define Ttk_RegisterElementSpec 0 +#endif /* TK_NO_DEPRECATED */ + #ifdef __GNUC__ /* * The rest of this file shouldn't warn about deprecated functions; they're diff --git a/generic/ttk/ttkTheme.c b/generic/ttk/ttkTheme.c index 4ecc30b..dff3c72 100644 --- a/generic/ttk/ttkTheme.c +++ b/generic/ttk/ttkTheme.c @@ -102,8 +102,9 @@ Tcl_Obj *Ttk_StyleDefault(Ttk_Style style, const char *optionName) while (style) { Tcl_HashEntry *entryPtr = Tcl_FindHashEntry(&style->defaultsTable, optionName); - if (entryPtr) + if (entryPtr) { return (Tcl_Obj *)Tcl_GetHashValue(entryPtr); + } style= style->parentStyle; } return 0; @@ -137,8 +138,9 @@ static const Tk_OptionSpec *TTKGetOptionSpec( { const Tk_OptionSpec *optionSpec = TkGetOptionSpec(optionName, optionTable); - if (!optionSpec) + if (!optionSpec) { return 0; + } /* Make sure widget option has a Tcl_Obj* entry: */ @@ -568,7 +570,7 @@ Ttk_CreateTheme( if (!newEntry) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "Theme %s already exists", name)); - Tcl_SetErrorCode(interp, "TTK", "THEME", "EXISTS", NULL); + Tcl_SetErrorCode(interp, "TTK", "THEME", "EXISTS", (char *)NULL); return NULL; } @@ -612,7 +614,7 @@ static Ttk_Theme LookupTheme( if (!entryPtr) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "theme \"%s\" does not exist", name)); - Tcl_SetErrorCode(interp, "TTK", "LOOKUP", "THEME", name, NULL); + Tcl_SetErrorCode(interp, "TTK", "LOOKUP", "THEME", name, (char *)NULL); return NULL; } @@ -910,7 +912,7 @@ Ttk_ElementClass *Ttk_RegisterElement( Tcl_ResetResult(interp); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "Duplicate element %s", name)); - Tcl_SetErrorCode(interp, "TTK", "REGISTER_ELEMENT", "DUPE", NULL); + Tcl_SetErrorCode(interp, "TTK", "REGISTER_ELEMENT", "DUPE", (char *)NULL); } return 0; } @@ -922,6 +924,7 @@ Ttk_ElementClass *Ttk_RegisterElement( return elementClass; } +#ifndef TK_NO_DEPRECATED /* Ttk_RegisterElementSpec (deprecated) -- * Register a new element. */ @@ -931,6 +934,7 @@ int Ttk_RegisterElementSpec(Ttk_Theme theme, return Ttk_RegisterElement(NULL, theme, name, specPtr, clientData) ? TCL_OK : TCL_ERROR; } +#endif /* TK_NO_DEPRECATED */ /*------------------------------------------------------------------------ * +++ Element record initialization. @@ -1121,11 +1125,11 @@ Ttk_DrawElement( Ttk_Box b, /* Element area */ Ttk_State state) /* Widget or element state flags. */ { - if (b.width <= 0 || b.height <= 0) + if (b.width <= 0 || b.height <= 0) { return; + } if (!InitializeElementRecord( - eclass, style, recordPtr, optionTable, tkwin, state)) - { + eclass, style, recordPtr, optionTable, tkwin, state)) { return; } eclass->specPtr->draw( @@ -1239,8 +1243,9 @@ usage: * (@@@ SHOULD: check for valid resource values as well, * but we don't know what types they should be at this level.) */ - if (!Ttk_GetStateMapFromObj(interp, stateMap)) + if (!Ttk_GetStateMapFromObj(interp, stateMap)) { return TCL_ERROR; + } entryPtr = Tcl_CreateHashEntry( &stylePtr->settingsTable,optionName,&newEntry); @@ -1380,7 +1385,7 @@ static int StyleThemeCurrentCmd( if (name == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "error: failed to get theme name", -1)); - Tcl_SetErrorCode(interp, "TTK", "THEME", "NAMELESS", NULL); + Tcl_SetErrorCode(interp, "TTK", "THEME", "NAMELESS", (char *)NULL); return TCL_ERROR; } @@ -1421,8 +1426,9 @@ static int StyleThemeCreateCmd( case OP_PARENT: parentTheme = LookupTheme( interp, pkgPtr, Tcl_GetString(objv[i+1])); - if (!parentTheme) + if (!parentTheme) { return TCL_ERROR; + } break; case OP_SETTINGS: settingsScript = objv[i+1]; @@ -1488,8 +1494,9 @@ StyleThemeSettingsCmd( } newTheme = LookupTheme(interp, pkgPtr, Tcl_GetString(objv[3])); - if (!newTheme) + if (!newTheme) { return TCL_ERROR; + } pkgPtr->currentTheme = newTheme; status = Tcl_EvalObjEx(interp, objv[4], 0); @@ -1583,7 +1590,7 @@ static int StyleElementOptionsCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "element %s not found", elementName)); - Tcl_SetErrorCode(interp, "TTK", "LOOKUP", "ELEMENT", elementName, NULL); + Tcl_SetErrorCode(interp, "TTK", "LOOKUP", "ELEMENT", elementName, (char *)NULL); return TCL_ERROR; } @@ -1647,8 +1654,9 @@ static int StyleThemeStylesCmd( } else { themePtr = Ttk_GetTheme(interp, Tcl_GetString(objv[3])); } - if (!themePtr) + if (!themePtr) { return TCL_ERROR; + } return TtkEnumerateHashTable(interp, &themePtr->styleTable); } diff --git a/generic/ttk/ttkTheme.h b/generic/ttk/ttkTheme.h index 5049b23..fc45157 100644 --- a/generic/ttk/ttkTheme.h +++ b/generic/ttk/ttkTheme.h @@ -391,7 +391,7 @@ MODULE_SCOPE int TtkEnumerateHashTable(Tcl_Interp *, Tcl_HashTable *); * +++ Stub table declarations. */ -#include "ttkDecls.h" +#include "ttkDecls.h" /* IWYU pragma: export */ /* * Drawing utilities for theme code: diff --git a/generic/ttk/ttkToggleswitch.c b/generic/ttk/ttkToggleswitch.c new file mode 100644 index 0000000..04cae23 --- /dev/null +++ b/generic/ttk/ttkToggleswitch.c @@ -0,0 +1,638 @@ +/* + * Copyright © 2025 Csaba Nemethi <csaba.nemethi@t-online.de> + * + * ttk::toggleswitch widget. + */ + +#include "tkInt.h" +#include "ttkTheme.h" +#include "ttkWidget.h" + +/* + * Tglswitch widget record + */ +typedef struct +{ + /* widget options */ + Tcl_Obj *commandObj; + Tcl_Obj *offValueObj; + Tcl_Obj *onValueObj; + Tcl_Obj *sizeObj; + Tcl_Obj *variableObj; + + /* internal state */ + Tcl_Obj *minValObj; /* minimum value */ + Tcl_Obj *maxValObj; /* maximum value */ + Tcl_Obj *curValObj; /* current value */ + Ttk_TraceHandle *varTrace; + double minVal, maxVal; +} TglswitchPart; + +typedef struct +{ + WidgetCore core; + TglswitchPart tglsw; +} Tglswitch; + +static const char *const sizeStrings[] = { "1", "2", "3", NULL }; + +static const Tk_OptionSpec TglswitchOptionSpecs[] = +{ + {TK_OPTION_STRING, "-command", "command", "Command", "", + offsetof(Tglswitch, tglsw.commandObj), TCL_INDEX_NONE, + 0, 0, 0}, + {TK_OPTION_STRING, "-offvalue", "offValue", "OffValue", "0", + offsetof(Tglswitch, tglsw.offValueObj), TCL_INDEX_NONE, + 0, 0, 0}, + {TK_OPTION_STRING, "-onvalue", "onValue", "OnValue", "1", + offsetof(Tglswitch, tglsw.onValueObj), TCL_INDEX_NONE, + 0, 0, 0}, + {TK_OPTION_STRING_TABLE, "-size", "size", "Size", "2", + offsetof(Tglswitch, tglsw.sizeObj), TCL_INDEX_NONE, + 0, sizeStrings, GEOMETRY_CHANGED}, + {TK_OPTION_STRING, "-variable", "variable", "Variable", NULL, + offsetof(Tglswitch, tglsw.variableObj), TCL_INDEX_NONE, + TK_OPTION_NULL_OK, 0, 0}, + + WIDGET_TAKEFOCUS_TRUE, + WIDGET_INHERIT_OPTIONS(ttkCoreOptionSpecs) +}; + +/* + * TglswitchVariableChanged -- + * Variable trace procedure for the ttk::toggleswitch -variable option. + * Updates the ttk::toggleswitch widget's switch state. + */ +static void TglswitchVariableChanged(void *clientData, const char *value) +{ + Tglswitch *tglswPtr = (Tglswitch *)clientData; + + if (WidgetDestroyed(&tglswPtr->core)) { + return; + } + + if (value == NULL) { + TtkWidgetChangeState(&tglswPtr->core, TTK_STATE_INVALID, 0); + } else { + Tcl_DecrRefCount(tglswPtr->tglsw.curValObj); + if (!strcmp(value, Tcl_GetString(tglswPtr->tglsw.onValueObj))) { + TtkWidgetChangeState(&tglswPtr->core, TTK_STATE_SELECTED, 0); + tglswPtr->tglsw.curValObj = tglswPtr->tglsw.maxValObj; + } else { + TtkWidgetChangeState(&tglswPtr->core, 0, TTK_STATE_SELECTED); + tglswPtr->tglsw.curValObj = tglswPtr->tglsw.minValObj; + } + Tcl_IncrRefCount(tglswPtr->tglsw.curValObj); + + TtkWidgetChangeState(&tglswPtr->core, 0, TTK_STATE_INVALID); + } + + TtkRedisplayWidget(&tglswPtr->core); +} + +/* + * TglswitchInitialize -- + * ttk::toggleswitch widget initialization hook. + */ +static void TglswitchInitialize(Tcl_Interp *interp, void *recordPtr) +{ + Tglswitch *tglswPtr = (Tglswitch *)recordPtr; + + /* + * Create the *Tglswitch*.trough and *Tglswitch*.slider + * elements for the Toggleswitch* styles if necessary + */ + int code = Tcl_EvalEx(interp, "ttk::toggleswitch::CondMakeElements", + TCL_INDEX_NONE, TCL_EVAL_GLOBAL); + if (code != TCL_OK) { + Tcl_BackgroundException(interp, code); + } + + /* + * Initialize the minimum, maximum, and current values + */ + + tglswPtr->tglsw.minVal = 0.0; + tglswPtr->tglsw.minValObj = Tcl_NewDoubleObj(tglswPtr->tglsw.minVal); + Tcl_IncrRefCount(tglswPtr->tglsw.minValObj); + + tglswPtr->tglsw.maxVal = 20.0; + tglswPtr->tglsw.maxValObj = Tcl_NewDoubleObj(tglswPtr->tglsw.maxVal); + Tcl_IncrRefCount(tglswPtr->tglsw.maxValObj); + + tglswPtr->tglsw.curValObj = Tcl_NewDoubleObj(0.0); + Tcl_IncrRefCount(tglswPtr->tglsw.curValObj); + + /* + * Set the -variable option to the widget's path name + */ + tglswPtr->tglsw.variableObj = + Tcl_NewStringObj(Tk_PathName(tglswPtr->core.tkwin), -1); + Tcl_IncrRefCount(tglswPtr->tglsw.variableObj); + + TtkTrackElementState(&tglswPtr->core); +} + +/* + * TglswitchCleanup -- + * Cleanup hook. + */ +static void TglswitchCleanup(void *recordPtr) +{ + Tglswitch *tglswPtr = (Tglswitch *)recordPtr; + + if (tglswPtr->tglsw.varTrace) { + Ttk_UntraceVariable(tglswPtr->tglsw.varTrace); + tglswPtr->tglsw.varTrace = 0; + } +} + +/* + * TglswitchConfigure -- + * Configuration hook. + */ +static int TglswitchConfigure(Tcl_Interp *interp, void *recordPtr, int mask) +{ + Tglswitch *tglswPtr = (Tglswitch *)recordPtr; + Tcl_Obj *variableObj = tglswPtr->tglsw.variableObj; + Ttk_TraceHandle *varTrace = NULL; + + if (mask & GEOMETRY_CHANGED) { + /* + * Processing the "-size" option: Set the "-style" option to + * "(*.)Toggleswitch{1|2|3}" if its value is of the same form. + */ + + const char *styleName = 0, *lastDot = 0, *nameTail = 0; + + if (tglswPtr->core.styleObj) { + styleName = Tcl_GetString(tglswPtr->core.styleObj); + } + if (!styleName || *styleName == '\0') { + styleName = "Toggleswitch2"; + } + lastDot = strrchr(styleName, '.'); + nameTail = lastDot ? lastDot + 1 : styleName; + + if (!strcmp(nameTail, "Toggleswitch1") + || !strcmp(nameTail, "Toggleswitch2") + || !strcmp(nameTail, "Toggleswitch3")) { + size_t length = strlen(styleName); + char *styleName2 = (char *)ckalloc(length + 1); + const char *sizeStr = Tcl_GetString(tglswPtr->tglsw.sizeObj); + + memcpy(styleName2, styleName, length + 1); + styleName2[length-1] = *sizeStr; + + Tcl_DecrRefCount(tglswPtr->core.styleObj); + tglswPtr->core.styleObj = Tcl_NewStringObj(styleName2, -1); + Tcl_IncrRefCount(tglswPtr->core.styleObj); + + ckfree(styleName2); + + /* + * Update the layout according to the new style + */ + TtkCoreConfigure(interp, recordPtr, STYLE_CHANGED); + } + } else if (mask & STYLE_CHANGED) { /* intentionally "else if" */ + /* + * Processing the "-style" option: Set the "-size" option + * to "1|2|3" if the style is "(*.)Toggleswitch{1|2|3}" + */ + + const char *sizeStr = 0; + const char *styleName = Tcl_GetString(tglswPtr->core.styleObj); + const char *lastDot = strrchr(styleName, '.'); + const char *nameTail = lastDot ? lastDot + 1 : styleName; + + if (!strcmp(nameTail, "Toggleswitch1")) { + sizeStr = "1"; + } else if (!strcmp(nameTail, "Toggleswitch2")) { + sizeStr = "2"; + } else if (!strcmp(nameTail, "Toggleswitch3")) { + sizeStr = "3"; + } + + if (sizeStr) { + Tcl_DecrRefCount(tglswPtr->tglsw.sizeObj); + tglswPtr->tglsw.sizeObj = Tcl_NewStringObj(sizeStr, -1); + Tcl_IncrRefCount(tglswPtr->tglsw.sizeObj); + } + } + + if (variableObj != NULL && *Tcl_GetString(variableObj) != '\0') { + varTrace = Ttk_TraceVariable(interp, variableObj, + TglswitchVariableChanged, recordPtr); + if (!varTrace) { + return TCL_ERROR; + } + } + + if (TtkCoreConfigure(interp, recordPtr, mask) != TCL_OK) { + Ttk_UntraceVariable(varTrace); + return TCL_ERROR; + } + + if (tglswPtr->tglsw.varTrace) { + Ttk_UntraceVariable(tglswPtr->tglsw.varTrace); + } + tglswPtr->tglsw.varTrace = varTrace; + + return TCL_OK; +} + +/* + * TglswitchPostConfigure -- + * Post-configuration hook. + */ +static int TglswitchPostConfigure( + TCL_UNUSED(Tcl_Interp *), + void *recordPtr, + TCL_UNUSED(int)) +{ + Tglswitch *tglswPtr = (Tglswitch *)recordPtr; + int status = TCL_OK; + + if (tglswPtr->tglsw.varTrace) { + status = Ttk_FireTrace(tglswPtr->tglsw.varTrace); + if (WidgetDestroyed(&tglswPtr->core)) { + return TCL_ERROR; + } + } + + return status; +} + +/* + * TglswitchGetLayout -- + * getLayout hook. + */ +static Ttk_Layout TglswitchGetLayout( + Tcl_Interp *interp, Ttk_Theme themePtr, void *recordPtr) +{ + Tglswitch *tglswPtr = (Tglswitch *)recordPtr; + const char *styleName = 0; + Tcl_DString dsStyleName; + Ttk_Layout layout; + + Tcl_DStringInit(&dsStyleName); + + if (tglswPtr->core.styleObj) { + styleName = Tcl_GetString(tglswPtr->core.styleObj); + Tcl_DStringAppend(&dsStyleName, styleName, TCL_INDEX_NONE); + } + if (!styleName || *styleName == '\0') { + const char *sizeStr = Tcl_GetString(tglswPtr->tglsw.sizeObj); + + styleName = tglswPtr->core.widgetSpec->className; + Tcl_DStringAppend(&dsStyleName, styleName, TCL_INDEX_NONE); + Tcl_DStringAppend(&dsStyleName, sizeStr, TCL_INDEX_NONE); + } + + layout = Ttk_CreateLayout(interp, themePtr, Tcl_DStringValue(&dsStyleName), + recordPtr, tglswPtr->core.optionTable, tglswPtr->core.tkwin); + + Tcl_DStringFree(&dsStyleName); + + return layout; +} + +/* + * TroughRange -- + * Returns the value area of the trough element, adjusted for slider size. + */ +static Ttk_Box TroughRange(Tglswitch *tglswPtr) +{ + Ttk_Box troughBox = Ttk_ClientRegion(tglswPtr->core.layout, "trough"); + Ttk_Element slider = Ttk_FindElement(tglswPtr->core.layout, "slider"); + + if (slider) { + Ttk_Box sliderBox = Ttk_ElementParcel(slider); + troughBox.x += sliderBox.width / 2; + troughBox.width -= sliderBox.width; + } + + return troughBox; +} + +/* + * ValueToFraction -- + * Returns the fraction corresponding to a given value. + */ +static double ValueToFraction(Tglswitch *tglswPtr, double value) +{ + double minVal = tglswPtr->tglsw.minVal; + double maxVal = tglswPtr->tglsw.maxVal; + double fraction = (value - minVal) / (maxVal - minVal); + + return fraction < 0 ? 0 : fraction > 1 ? 1 : fraction; +} + +/* + * ValueToPoint -- + * Returns the x coordinate corresponding to a given value. + */ +static int ValueToPoint(Tglswitch *tglswPtr, double value) +{ + Ttk_Box troughBox = TroughRange(tglswPtr); + double fraction = ValueToFraction(tglswPtr, value); + + return troughBox.x + (int)(fraction * troughBox.width); +} + +/* + * PointToValue -- + * Returns the value corresponding to a given x coordinate. + */ +static double PointToValue(Tglswitch *tglswPtr, int x) +{ + Ttk_Box troughBox = TroughRange(tglswPtr); + double minVal = tglswPtr->tglsw.minVal; + double maxVal = tglswPtr->tglsw.maxVal; + double value = 0.0, fraction; + + Tcl_GetDoubleFromObj(NULL, tglswPtr->tglsw.curValObj, &value); + if (troughBox.width <= 0) { + return value; + } + + fraction = (double)(x - troughBox.x) / (double)troughBox.width; + fraction = fraction < 0 ? 0 : fraction > 1 ? 1 : fraction; + + return minVal + fraction * (maxVal - minVal); +} + +/* + * TglswitchDoLayout -- + */ +static void TglswitchDoLayout(void *clientData) +{ + WidgetCore *corePtr = (WidgetCore *)clientData; + Ttk_Element slider = Ttk_FindElement(corePtr->layout, "slider"); + + Ttk_PlaceLayout(corePtr->layout, corePtr->state, + Ttk_WinBox(corePtr->tkwin)); + + /* + * Adjust the slider position + */ + if (slider) { + Tglswitch *tglswPtr = (Tglswitch *)clientData; + Ttk_Box troughBox = Ttk_ClientRegion(tglswPtr->core.layout, "trough"); + Ttk_Box sliderBox = Ttk_ElementParcel(slider); + double value = 0.0; + double fraction; + int range; + + Tcl_GetDoubleFromObj(NULL, tglswPtr->tglsw.curValObj, &value); + fraction = ValueToFraction(tglswPtr, value); + range = troughBox.width - sliderBox.width; + + sliderBox.x += (int)(fraction * range); + Ttk_PlaceElement(corePtr->layout, slider, sliderBox); + } +} + +/* + * $toggleswitch get ?min|max|$x? -- + * Returns the ttk::toggleswitch widget's current/minimum/maximum value, + * or the value corresponding to $x. + */ +static int TglswitchGetCommand( + void *recordPtr, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[]) +{ + Tglswitch *tglswPtr = (Tglswitch *)recordPtr; + char *arg2 = NULL; + int x, res = TCL_OK; + double value = 0.0; + + if (objc == 2) { + Tcl_SetObjResult(interp, tglswPtr->tglsw.curValObj); + } else if (objc == 3) { + arg2 = Tcl_GetString(objv[2]); + if (!strcmp(arg2, "min")) { + Tcl_SetObjResult(interp, tglswPtr->tglsw.minValObj); + } else if (!strcmp(arg2, "max")) { + Tcl_SetObjResult(interp, tglswPtr->tglsw.maxValObj); + } else { + res = Tcl_GetIntFromObj(interp, objv[2], &x); + if (res == TCL_OK) { + value = PointToValue(tglswPtr, x); + Tcl_SetObjResult(interp, Tcl_NewDoubleObj(value)); + } + } + } else { + Tcl_WrongNumArgs(interp, 1, objv, "get ?min|max|x?"); + return TCL_ERROR; + } + + return res; +} + +/* + * $toggleswitch set $newValue + * Sets the ttk::toggleswitch widget's value to $newValue. + */ +static int TglswitchSetCommand( + void *recordPtr, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[]) +{ + Tglswitch *tglswPtr = (Tglswitch *)recordPtr; + double minVal = tglswPtr->tglsw.minVal; + double maxVal = tglswPtr->tglsw.maxVal; + double value; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "set value"); + return TCL_ERROR; + } + + if (Tcl_GetDoubleFromObj(interp, objv[2], &value) != TCL_OK) { + return TCL_ERROR; + } + + if (tglswPtr->core.state & TTK_STATE_DISABLED) { + return TCL_OK; + } + + /* + * Limit new value to between minVal and maxVal + */ + value = value < minVal ? minVal : value > maxVal ? maxVal : value; + + /* + * Set value + */ + Tcl_DecrRefCount(tglswPtr->tglsw.curValObj); + tglswPtr->tglsw.curValObj = Tcl_NewDoubleObj(value); + Tcl_IncrRefCount(tglswPtr->tglsw.curValObj); + TtkRedisplayWidget(&tglswPtr->core); + + if (WidgetDestroyed(&tglswPtr->core)) { + return TCL_ERROR; + } + + return TCL_OK; +} + +/* + * $toggleswitch switchstate ?$boolean? -- + * Modifies or inquires the widget's switch state. + */ +static int TglswitchSwitchstateCommand( + void *recordPtr, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[]) +{ + Tglswitch *tglswPtr = (Tglswitch *)recordPtr; + Ttk_State selState = (tglswPtr->core.state & TTK_STATE_SELECTED); + Tcl_Obj *variableObj = tglswPtr->tglsw.variableObj; + int arg2 = 0; + + if (objc == 2) { + /* + * Return the widget's current switch state + */ + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(selState)); + } else if (objc == 3) { + if (Tcl_GetBooleanFromObj(interp, objv[2], &arg2) != TCL_OK) { + return TCL_ERROR; + } + + if (tglswPtr->core.state & TTK_STATE_DISABLED) { + return TCL_OK; + } + + /* + * Update the widget's selected state and current value + */ + Tcl_DecrRefCount(tglswPtr->tglsw.curValObj); + if (arg2) { + TtkWidgetChangeState(&tglswPtr->core, TTK_STATE_SELECTED, 0); + tglswPtr->tglsw.curValObj = tglswPtr->tglsw.maxValObj; + } else { + TtkWidgetChangeState(&tglswPtr->core, 0, TTK_STATE_SELECTED); + tglswPtr->tglsw.curValObj = tglswPtr->tglsw.minValObj; + } + Tcl_IncrRefCount(tglswPtr->tglsw.curValObj); + + if (variableObj != NULL && *Tcl_GetString(variableObj) != '\0') { + /* + * Update the associated variable + */ + Tcl_Obj *newOnOffValueObj = arg2 ? tglswPtr->tglsw.onValueObj + : tglswPtr->tglsw.offValueObj; + if (Tcl_ObjSetVar2(interp, variableObj, NULL, newOnOffValueObj, + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { + return TCL_ERROR; + } + } + + if (WidgetDestroyed(&tglswPtr->core)) { + return TCL_ERROR; + } + + if ((tglswPtr->core.state & TTK_STATE_SELECTED) != selState) { + /* + * Evaluate the associated command at global scope + */ + return Tcl_EvalObjEx(interp, tglswPtr->tglsw.commandObj, + TCL_EVAL_GLOBAL); + } + } else { + Tcl_WrongNumArgs(interp, 1, objv, "switchstate ?boolean?"); + return TCL_ERROR; + } + + return TCL_OK; +} + +/* + * $toggleswitch toggle -- + * Toggles the widget's switch state. + */ +static int TglswitchToggleCommand( + void *recordPtr, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[]) +{ + Tglswitch *tglswPtr = (Tglswitch *)recordPtr; + static Tcl_Obj *newObjv[3]; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "toggle"); + return TCL_ERROR; + } + + newObjv[0] = objv[0]; + newObjv[1] = Tcl_NewStringObj("switchstate", -1); + newObjv[2] = (tglswPtr->core.state & TTK_STATE_SELECTED) ? + Tcl_NewBooleanObj(0) : Tcl_NewBooleanObj(1); + + return TglswitchSwitchstateCommand(recordPtr, interp, 3, newObjv); +} + +/* + * $toggleswitch xcoord ?$value? -- + * Returns the x coordinate corresponding to $value, or to the current + * value if $value is omitted. + */ +static int TglswitchXcoordCommand( + void *recordPtr, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[]) +{ + Tglswitch *tglswPtr = (Tglswitch *)recordPtr; + double value; + int res = TCL_OK; + + if (objc == 3) { + res = Tcl_GetDoubleFromObj(interp, objv[2], &value); + } else if (objc == 2) { + res = Tcl_GetDoubleFromObj(interp, tglswPtr->tglsw.curValObj, &value); + } else { + Tcl_WrongNumArgs(interp, 1, objv, "xcoord ?value?"); + return TCL_ERROR; + } + + if (res == TCL_OK) { + int x = ValueToPoint(tglswPtr, value); + Tcl_SetObjResult(interp, Tcl_NewIntObj(x)); + } + + return res; +} + +static const Ttk_Ensemble TglswitchCommands[] = +{ + { "cget", TtkWidgetCgetCommand, 0 }, + { "configure", TtkWidgetConfigureCommand, 0 }, + { "get", TglswitchGetCommand, 0 }, + { "identify", TtkWidgetIdentifyCommand, 0 }, + { "instate", TtkWidgetInstateCommand, 0 }, + { "set", TglswitchSetCommand, 0 }, + { "state", TtkWidgetStateCommand, 0 }, + { "style", TtkWidgetStyleCommand, 0 }, + { "switchstate", TglswitchSwitchstateCommand, 0 }, + { "toggle", TglswitchToggleCommand, 0 }, + { "xcoord", TglswitchXcoordCommand, 0 }, + { 0, 0, 0 } +}; + +static const WidgetSpec TglswitchWidgetSpec = +{ + "Toggleswitch", /* Class name */ + sizeof(Tglswitch), /* record size */ + TglswitchOptionSpecs, /* option specs */ + TglswitchCommands, /* widget commands */ + TglswitchInitialize, /* initialization proc */ + TglswitchCleanup, /* cleanup proc */ + TglswitchConfigure, /* configure proc */ + TglswitchPostConfigure, /* postConfigure */ + TglswitchGetLayout, /* getLayoutProc */ + TtkWidgetSize, /* sizeProc */ + TglswitchDoLayout, /* layoutProc */ + TtkWidgetDisplay /* displayProc */ +}; + +/* + * Initialization. + */ +MODULE_SCOPE void TtkToggleswitch_Init(Tcl_Interp *interp) +{ + RegisterWidget(interp, "ttk::toggleswitch", &TglswitchWidgetSpec); +} diff --git a/generic/ttk/ttkTrack.c b/generic/ttk/ttkTrack.c index 032a672..cce6259 100644 --- a/generic/ttk/ttkTrack.c +++ b/generic/ttk/ttkTrack.c @@ -69,8 +69,9 @@ static void ActivateElement(ElementStateTracker *es, Ttk_Element element) */ static void ReleaseElement(ElementStateTracker *es) { - if (!es->pressedElement) + if (!es->pressedElement) { return; + } Ttk_ChangeElementState( es->pressedElement, 0,TTK_STATE_PRESSED|TTK_STATE_ACTIVE); @@ -78,8 +79,9 @@ static void ReleaseElement(ElementStateTracker *es) /* Reactivate element under the mouse cursor: */ - if (es->activeElement) - Ttk_ChangeElementState(es->activeElement, TTK_STATE_ACTIVE,0); + if (es->activeElement) { + Ttk_ChangeElementState(es->activeElement, TTK_STATE_ACTIVE, 0); + } TtkRedisplayWidget(es->corePtr); } @@ -138,8 +140,9 @@ ElementStateEventProc(void *clientData, XEvent *ev) break; case LeaveNotify: ActivateElement(es, 0); - if (ev->xcrossing.mode == NotifyGrab) + if (ev->xcrossing.mode == NotifyGrab) { PressElement(es, 0); + } break; case EnterNotify: element = Ttk_IdentifyElement( @@ -149,8 +152,9 @@ ElementStateEventProc(void *clientData, XEvent *ev) case ButtonPress: element = Ttk_IdentifyElement( layout, ev->xbutton.x, ev->xbutton.y); - if (element) + if (element) { PressElement(es, element); + } break; case ButtonRelease: ReleaseElement(es); diff --git a/generic/ttk/ttkTreeview.c b/generic/ttk/ttkTreeview.c index f430aec..ea01b25 100644 --- a/generic/ttk/ttkTreeview.c +++ b/generic/ttk/ttkTreeview.c @@ -172,12 +172,15 @@ static void FreeItemCB(void *clientData) { FreeItem((TreeItem *)clientData); } */ static void DetachItem(TreeItem *item) { - if (item->parent && item->parent->children == item) + if (item->parent && item->parent->children == item) { item->parent->children = item->next; - if (item->prev) + } + if (item->prev) { item->prev->next = item->next; - if (item->next) + } + if (item->next) { item->next->prev = item->prev; + } item->next = item->prev = item->parent = NULL; } @@ -210,12 +213,14 @@ static void InsertItem(TreeItem *parent, TreeItem *prev, TreeItem *item) static TreeItem *NextPreorder(TreeItem *item) { - if (item->children) + if (item->children) { return item->children; + } while (!item->next) { item = item->parent; - if (!item) + if (!item) { return 0; + } } return item->next; } @@ -404,8 +409,9 @@ static int GetEnumSetFromObj( Tcl_Size i, objc; Tcl_Obj **objv; - if (Tcl_ListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) + if (Tcl_ListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) { return TCL_ERROR; + } for (i = 0; i < objc; ++i) { int index; @@ -668,7 +674,7 @@ static TreeColumn *GetColumn( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "Column index \"%s\" out of bounds", Tcl_GetString(columnIDObj))); - Tcl_SetErrorCode(interp, "TTK", "TREE", "COLBOUND", NULL); + Tcl_SetErrorCode(interp, "TTK", "TREE", "COLBOUND", (char *)NULL); return NULL; } @@ -676,7 +682,7 @@ static TreeColumn *GetColumn( } Tcl_SetObjResult(interp, Tcl_ObjPrintf( "Invalid column index \"%s\"", Tcl_GetString(columnIDObj))); - Tcl_SetErrorCode(interp, "TTK", "TREE", "COLUMN", NULL); + Tcl_SetErrorCode(interp, "TTK", "TREE", "COLUMN", (char *)NULL); return NULL; } @@ -688,15 +694,15 @@ static TreeColumn *FindColumn( { Tcl_WideInt colno; - if (sscanf(Tcl_GetString(columnIDObj), "#%" TCL_LL_MODIFIER "d", &colno) == 1) - { /* Display column specification, #n */ + if (sscanf(Tcl_GetString(columnIDObj), "#%" TCL_LL_MODIFIER "d", &colno) == 1) { + /* Display column specification, #n */ if (colno >= 0 && colno < tv->tree.nDisplayColumns) { return tv->tree.displayColumns[colno]; } /* else */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "Column %s out of range", Tcl_GetString(columnIDObj))); - Tcl_SetErrorCode(interp, "TTK", "TREE", "COLUMN", NULL); + Tcl_SetErrorCode(interp, "TTK", "TREE", "COLUMN", (char *)NULL); return NULL; } @@ -716,7 +722,7 @@ static TreeItem *FindItem( if (!entryPtr) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "Item %s not found", itemName)); - Tcl_SetErrorCode(interp, "TTK", "TREE", "ITEM", NULL); + Tcl_SetErrorCode(interp, "TTK", "TREE", "ITEM", (char *)NULL); return 0; } return (TreeItem *)Tcl_GetHashValue(entryPtr); @@ -876,8 +882,9 @@ static int TreeviewInitDisplayColumns(Tcl_Interp *interp, Treeview *tv) } displayColumns[0] = &tv->tree.column0; - if (tv->tree.displayColumns) + if (tv->tree.displayColumns) { ckfree(tv->tree.displayColumns); + } tv->tree.displayColumns = displayColumns; tv->tree.nDisplayColumns = ndcols + 1; @@ -1082,7 +1089,7 @@ static int GetCellFromObj( if (nElements != 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "Cell id must be a list of two elements", -1)); - Tcl_SetErrorCode(interp, "TTK", "TREE", "CELL", NULL); + Tcl_SetErrorCode(interp, "TTK", "TREE", "CELL", (char *)NULL); return TCL_ERROR; } /* Valid item/column in each pair? */ @@ -1107,7 +1114,7 @@ static int GetCellFromObj( if (i == tv->tree.nDisplayColumns) { /* specified column unviewable */ Tcl_SetObjResult(interp, Tcl_NewStringObj( "Cell id must be in a visible column", -1)); - Tcl_SetErrorCode(interp, "TTK", "TREE", "CELL", NULL); + Tcl_SetErrorCode(interp, "TTK", "TREE", "CELL", (char *)NULL); return TCL_ERROR; } if (displayColumn != NULL) { @@ -1347,8 +1354,9 @@ static void TreeviewCleanup(void *recordPtr) FreeColumn(&tv->tree.column0); TreeviewFreeColumns(tv); - if (tv->tree.displayColumns) + if (tv->tree.displayColumns) { ckfree(tv->tree.displayColumns); + } foreachHashEntry(&tv->tree.items, FreeItemCB); Tcl_DeleteHashTable(&tv->tree.items); @@ -1370,13 +1378,15 @@ TreeviewConfigure(Tcl_Interp *interp, void *recordPtr, int mask) unsigned showFlags = tv->tree.showFlags; if (mask & COLUMNS_CHANGED) { - if (TreeviewInitColumns(interp, tv) != TCL_OK) + if (TreeviewInitColumns(interp, tv) != TCL_OK) { return TCL_ERROR; + } mask |= DCOLUMNS_CHANGED; } if (mask & DCOLUMNS_CHANGED) { - if (TreeviewInitDisplayColumns(interp, tv) != TCL_OK) + if (TreeviewInitDisplayColumns(interp, tv) != TCL_OK) { return TCL_ERROR; + } } if (mask & COLUMNS_CHANGED) { CellSelectionClear(tv); @@ -1385,14 +1395,14 @@ TreeviewConfigure(Tcl_Interp *interp, void *recordPtr, int mask) Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"#%" TCL_SIZE_MODIFIER "d\" is out of range", tv->tree.nTitleColumns)); - Tcl_SetErrorCode(interp, "TTK", "TREE", "TITLECOLUMNS", NULL); + Tcl_SetErrorCode(interp, "TTK", "TREE", "TITLECOLUMNS", (char *)NULL); return TCL_ERROR; } if (tv->tree.nTitleItems < 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%" TCL_SIZE_MODIFIER "d\" is out of range", tv->tree.nTitleItems)); - Tcl_SetErrorCode(interp, "TTK", "TREE", "TITLEITEMS", NULL); + Tcl_SetErrorCode(interp, "TTK", "TREE", "TITLEITEMS", (char *)NULL); return TCL_ERROR; } if (mask & SCROLLCMD_CHANGED) { @@ -1441,8 +1451,9 @@ static int ConfigureItem( */ if (item->valuesObj) { Tcl_Size unused; - if (Tcl_ListObjLength(interp, item->valuesObj, &unused) != TCL_OK) + if (Tcl_ListObjLength(interp, item->valuesObj, &unused) != TCL_OK) { goto error; + } } /* Check -height @@ -1450,7 +1461,7 @@ static int ConfigureItem( if (item->height < 1) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "Invalid item height %d", item->height)); - Tcl_SetErrorCode(interp, "TTK", "TREE", "HEIGHT", NULL); + Tcl_SetErrorCode(interp, "TTK", "TREE", "HEIGHT", (char *)NULL); goto error; } @@ -1480,12 +1491,14 @@ static int ConfigureItem( */ if (item->openObj) { int isOpen; - if (Tcl_GetBooleanFromObj(interp, item->openObj, &isOpen) != TCL_OK) + if (Tcl_GetBooleanFromObj(interp, item->openObj, &isOpen) != TCL_OK) { goto error; - if (isOpen) + } + if (isOpen) { item->state |= TTK_STATE_OPEN; - else + } else { item->state &= ~TTK_STATE_OPEN; + } } /* All OK. @@ -1530,7 +1543,7 @@ static int ConfigureColumn( if (mask & READONLY_OPTION) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "Attempt to change read-only option", -1)); - Tcl_SetErrorCode(interp, "TTK", "TREE", "READONLY", NULL); + Tcl_SetErrorCode(interp, "TTK", "TREE", "READONLY", (char *)NULL); goto error; } @@ -1889,8 +1902,9 @@ static Ttk_Layout GetSublayout( interp, themePtr, parentLayout, layoutName, optionTable); if (newLayout) { - if (*layoutPtr) + if (*layoutPtr) { Ttk_FreeLayout(*layoutPtr); + } *layoutPtr = newLayout; } return newLayout; @@ -2036,10 +2050,12 @@ static int TreeviewSize(void *clientData, int *widthPtr, int *heightPtr) static Ttk_State ItemState(Treeview *tv, TreeItem *item) { Ttk_State state = tv->core.state | item->state; - if (!item->children) + if (!item->children) { state |= TTK_STATE_LEAF; - if (item != tv->tree.focus) + } + if (item != tv->tree.focus) { state &= ~TTK_STATE_FOCUS; + } return state; } @@ -2591,7 +2607,7 @@ static int AncestryCheck( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "Cannot insert %s as descendant of %s", ItemName(tv, item), ItemName(tv, parent))); - Tcl_SetErrorCode(interp, "TTK", "TREE", "ANCESTRY", NULL); + Tcl_SetErrorCode(interp, "TTK", "TREE", "ANCESTRY", (char *)NULL); return 0; } p = p->parent; @@ -2653,8 +2669,9 @@ static int TreeviewChildrenCommand( TreeItem *child; int i; - if (!newChildren) + if (!newChildren) { return TCL_ERROR; + } /* Sanity-check: */ @@ -2935,10 +2952,12 @@ static int TreeviewHorribleIdentify( done: result = Tcl_NewListObj(0,0); Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj(what, -1)); - if (item) + if (item) { Tcl_ListObjAppendElement(NULL, result, ItemID(tv, item)); - if (detail) + } + if (detail) { Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj(detail, -1)); + } Tcl_SetObjResult(interp, result); return TCL_OK; @@ -3170,8 +3189,9 @@ static int TreeviewSetCommand( Tcl_WrongNumArgs(interp, 2, objv, "item ?column ?value??"); return TCL_ERROR; } - if (!(item = FindItem(interp, tv, objv[2]))) + if (!(item = FindItem(interp, tv, objv[2]))) { return TCL_ERROR; + } /* Make sure -values exists: */ @@ -3199,14 +3219,15 @@ static int TreeviewSetCommand( /* else -- get or set column */ - if (!(column = FindColumn(interp, tv, objv[3]))) + if (!(column = FindColumn(interp, tv, objv[3]))) { return TCL_ERROR; + } if (column == &tv->tree.column0) { /* @@@ Maybe set -text here instead? */ Tcl_SetObjResult(interp, Tcl_NewStringObj( "Display column #0 cannot be set", -1)); - Tcl_SetErrorCode(interp, "TTK", "TREE", "COLUMN_0", NULL); + Tcl_SetErrorCode(interp, "TTK", "TREE", "COLUMN_0", (char *)NULL); return TCL_ERROR; } @@ -3277,8 +3298,9 @@ static int TreeviewInsertCommand( sibling = EndPosition(tv, parent); } else { int index; - if (Tcl_GetIntFromObj(interp, objv[3], &index) != TCL_OK) + if (Tcl_GetIntFromObj(interp, objv[3], &index) != TCL_OK) { return TCL_ERROR; + } sibling = InsertPosition(parent, index); } @@ -3294,7 +3316,7 @@ static int TreeviewInsertCommand( if (!isNew) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "Item %s already exists", itemName)); - Tcl_SetErrorCode(interp, "TTK", "TREE", "ITEM_EXISTS", NULL); + Tcl_SetErrorCode(interp, "TTK", "TREE", "ITEM_EXISTS", (char *)NULL); return TCL_ERROR; } objc -= 2; objv += 2; @@ -3354,7 +3376,7 @@ static int TreeviewDetachCommand( if (items[i] == tv->tree.root) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "Cannot detach root item", -1)); - Tcl_SetErrorCode(interp, "TTK", "TREE", "ROOT", NULL); + Tcl_SetErrorCode(interp, "TTK", "TREE", "ROOT", (char *)NULL); ckfree(items); return TCL_ERROR; } @@ -3443,7 +3465,7 @@ static int TreeviewDeleteCommand( ckfree(items); Tcl_SetObjResult(interp, Tcl_NewStringObj( "Cannot delete root item", -1)); - Tcl_SetErrorCode(interp, "TTK", "TREE", "ROOT", NULL); + Tcl_SetErrorCode(interp, "TTK", "TREE", "ROOT", (char *)NULL); return TCL_ERROR; } } @@ -3468,10 +3490,12 @@ static int TreeviewDeleteCommand( */ while (delq) { TreeItem *next = delq->next; - if (tv->tree.focus == delq) + if (tv->tree.focus == delq) { tv->tree.focus = 0; - if (tv->tree.endPtr == delq) + } + if (tv->tree.endPtr == delq) { tv->tree.endPtr = 0; + } FreeItem(delq); delq = next; } @@ -3676,7 +3700,7 @@ static int TreeviewDragCommand( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "column %s is not displayed", Tcl_GetString(objv[2]))); - Tcl_SetErrorCode(interp, "TTK", "TREE", "COLUMN_INVISIBLE", NULL); + Tcl_SetErrorCode(interp, "TTK", "TREE", "COLUMN_INVISIBLE", (char *)NULL); return TCL_ERROR; } @@ -3712,8 +3736,9 @@ static int TreeviewFocusCommand( return TCL_OK; } else if (objc == 3) { TreeItem *newFocus = FindItem(interp, tv, objv[2]); - if (!newFocus) + if (!newFocus) { return TCL_ERROR; + } tv->tree.focus = newFocus; TtkRedisplayWidget(&tv->core); return TCL_OK; @@ -3742,8 +3767,9 @@ static int TreeviewSelectionCommand( if (objc == 2) { Tcl_Obj *result = Tcl_NewListObj(0,0); for (item = tv->tree.root->children; item; item = NextPreorder(item)) { - if (item->state & TTK_STATE_SELECTED) + if (item->state & TTK_STATE_SELECTED) { Tcl_ListObjAppendElement(NULL, result, ItemID(tv, item)); + } } Tcl_SetObjResult(interp, result); return TCL_OK; @@ -4106,7 +4132,7 @@ static int TreeviewTagBindCommand( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unsupported event %s\nonly key, button, motion, and" " virtual events supported", sequence)); - Tcl_SetErrorCode(interp, "TTK", "TREE", "BIND_EVENTS", NULL); + Tcl_SetErrorCode(interp, "TTK", "TREE", "BIND_EVENTS", (char *)NULL); return TCL_ERROR; } } diff --git a/generic/ttk/ttkWidget.c b/generic/ttk/ttkWidget.c index 3c345d2..40b8ee1 100644 --- a/generic/ttk/ttkWidget.c +++ b/generic/ttk/ttkWidget.c @@ -202,8 +202,9 @@ WidgetInstanceObjCmdDeleted(void *clientData) { WidgetCore *corePtr = (WidgetCore *)clientData; corePtr->widgetCmd = NULL; - if (corePtr->tkwin != NULL) + if (corePtr->tkwin != NULL) { Tk_DestroyWindow(corePtr->tkwin); + } } /* DestroyWidget -- @@ -288,10 +289,11 @@ static void CoreEventProc(void *clientData, XEvent *eventPtr) || eventPtr->xfocus.detail == NotifyAncestor || eventPtr->xfocus.detail == NotifyNonlinear) { - if (eventPtr->type == FocusIn) + if (eventPtr->type == FocusIn) { corePtr->state |= TTK_STATE_FOCUS; - else + } else { corePtr->state &= ~TTK_STATE_FOCUS; + } TtkRedisplayWidget(corePtr); } break; @@ -367,8 +369,9 @@ int TtkWidgetConstructorObjCmd( tkwin = Tk_CreateWindowFromPath( interp, Tk_MainWindow(interp), Tcl_GetString(objv[1]), NULL); - if (tkwin == NULL) + if (tkwin == NULL) { return TCL_ERROR; + } /* * Allocate and initialize the widget record. @@ -411,13 +414,16 @@ int TtkWidgetConstructorObjCmd( } else { Tk_FreeSavedOptions(&savedOptions); } - if (widgetSpec->configureProc(interp, recordPtr, ~0) != TCL_OK) + if (widgetSpec->configureProc(interp, recordPtr, ~0) != TCL_OK) { goto error; - if (widgetSpec->postConfigureProc(interp, recordPtr, ~0) != TCL_OK) + } + if (widgetSpec->postConfigureProc(interp, recordPtr, ~0) != TCL_OK) { goto error; + } - if (WidgetDestroyed(corePtr)) + if (WidgetDestroyed(corePtr)) { goto error; + } Tcl_Release(corePtr); @@ -453,11 +459,13 @@ Ttk_Layout TtkWidgetGetLayout( WidgetCore *corePtr = (WidgetCore *)recordPtr; const char *styleName = 0; - if (corePtr->styleObj) + if (corePtr->styleObj) { styleName = Tcl_GetString(corePtr->styleObj); + } - if (!styleName || *styleName == '\0') + if (!styleName || *styleName == '\0') { styleName = corePtr->widgetSpec->className; + } return Ttk_CreateLayout(interp, themePtr, styleName, recordPtr, corePtr->optionTable, corePtr->tkwin); @@ -483,17 +491,20 @@ Ttk_Layout TtkWidgetGetOrientedLayout( /* Prefix: */ Ttk_GetOrientFromObj(NULL, orientObj, &orient); - if (orient == TTK_ORIENT_HORIZONTAL) + if (orient == TTK_ORIENT_HORIZONTAL) { Tcl_DStringAppend(&styleName, "Horizontal.", TCL_INDEX_NONE); - else + } else { Tcl_DStringAppend(&styleName, "Vertical.", TCL_INDEX_NONE); + } /* Add base style name: */ - if (corePtr->styleObj) + if (corePtr->styleObj) { baseStyleName = Tcl_GetString(corePtr->styleObj); - if (!baseStyleName || *baseStyleName == '\0') + } + if (!baseStyleName || *baseStyleName == '\0') { baseStyleName = corePtr->widgetSpec->className; + } Tcl_DStringAppend(&styleName, baseStyleName, TCL_INDEX_NONE); @@ -598,8 +609,9 @@ int TtkWidgetCgetCommand( } result = Tk_GetOptionValue(interp, recordPtr, corePtr->optionTable, objv[2], corePtr->tkwin); - if (result == NULL) + if (result == NULL) { return TCL_ERROR; + } Tcl_SetObjResult(interp, result); return TCL_OK; } @@ -626,8 +638,9 @@ int TtkWidgetConfigureCommand( status = Tk_SetOptions(interp, recordPtr, corePtr->optionTable, objc - 2, objv + 2, corePtr->tkwin, &savedOptions, &mask); - if (status != TCL_OK) + if (status != TCL_OK) { return status; + } if (mask & READONLY_OPTION) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -695,8 +708,9 @@ int TtkWidgetStateCommand( return TCL_ERROR; } status = Ttk_GetStateSpecFromObj(interp, objv[2], &spec); - if (status != TCL_OK) + if (status != TCL_OK) { return status; + } oldState = corePtr->state; corePtr->state = Ttk_ModifyState(corePtr->state, &spec); @@ -729,8 +743,9 @@ int TtkWidgetInstateCommand( return TCL_ERROR; } status = Ttk_GetStateSpecFromObj(interp, objv[2], &spec); - if (status != TCL_OK) + if (status != TCL_OK) { return status; + } if (objc == 3) { Tcl_SetObjResult(interp, diff --git a/library/console.tcl b/library/console.tcl index 45f7e46..37a0653 100644 --- a/library/console.tcl +++ b/library/console.tcl @@ -158,8 +158,13 @@ proc ::tk::ConsoleInit {} { ConsoleBind $con + if {[tk windowingsystem] eq "aqua"} { + $con tag configure stdin -foreground systemLinkColor + } else { + $con tag configure stdin -foreground blue + } + $con tag configure stderr -foreground red - $con tag configure stdin -foreground blue $con tag configure prompt -foreground \#8F4433 $con tag configure proc -foreground \#008800 $con tag configure var -background \#FFC0D0 diff --git a/library/demos/print.tcl b/library/demos/print.tcl index a1ef1f5..e8f7fb1 100644 --- a/library/demos/print.tcl +++ b/library/demos/print.tcl @@ -67,6 +67,7 @@ lassign [$c bbox $imgId] x1 y1 x2 y2 ;# x1, y1, x2, y2 are in pixels incr y2 [expr {round(15 * [tk scaling])}] ;# convert 15 pt to pixels $c create text 15p $y2 -anchor nw -font {Helvetica 12} \ + -fill black \ -text "A short demo of simple canvas elements." set txt { diff --git a/library/demos/ttkbut.tcl b/library/demos/ttkbut.tcl index f567790..98afa08 100644 --- a/library/demos/ttkbut.tcl +++ b/library/demos/ttkbut.tcl @@ -1,8 +1,8 @@ # ttkbut.tcl -- # # This demonstration script creates a toplevel window containing several -# simple Ttk widgets, such as labels, labelframes, buttons, checkbuttons and -# radiobuttons. +# simple Ttk widgets, such as labels, labelframes, buttons, checkbuttons, +# radiobuttons, a separator and a toggleswitch. if {![info exists widgetDemo]} { error "This script should be run from the \"widget\" demo." @@ -17,7 +17,7 @@ wm title $w "Simple Ttk Widgets" wm iconname $w "ttkbut" positionWindow $w -ttk::label $w.msg -font $font -wraplength 4i -justify left -text "Ttk is the new Tk themed widget set. This is a Ttk themed label, and below are three groups of Ttk widgets in Ttk labelframes. The first group are all buttons that set the current application theme when pressed. The second group contains three sets of checkbuttons, with a separator widget between the sets. Note that the “Enabled” button controls whether all the other themed widgets in this toplevel are in the disabled state. The third group has a collection of linked radiobuttons." +ttk::label $w.msg -font $font -wraplength 4i -justify left -text "Ttk is the new Tk themed widget set. This is a Ttk themed label, and below are four groups of Ttk widgets in Ttk labelframes. The first group are all buttons that set the current application theme when pressed. The second group contains two sets of checkbuttons, with a separator widget between the sets. The third group has a collection of linked radiobuttons. Finally, the toggleswitch in the fourth labelframe controls whether all the themed widgets in this toplevel, except that labelframe and its children, are in the disabled state." pack $w.msg -side top -fill x ## See Code / Dismiss @@ -32,7 +32,29 @@ foreach theme [lsort [ttk::themes]] { pack $w.buttons.$theme -pady 1.5p } -## Helper procedure for the top checkbutton +## Set up the checkbutton group +ttk::labelframe $w.checks -text "Checkbuttons" +ttk::checkbutton $w.checks.c1 -text Cheese -variable cheese +ttk::checkbutton $w.checks.c2 -text Tomato -variable tomato +ttk::separator $w.checks.sep +ttk::checkbutton $w.checks.c3 -text Basil -variable basil +ttk::checkbutton $w.checks.c4 -text Oregano -variable oregano +### pack $w.checks.e $w.checks.sep1 $w.checks.c1 $w.checks.c2 $w.checks.sep2 \ + $w.checks.c3 $w.checks.c4 -fill x -pady 1.5p +pack $w.checks.c1 $w.checks.c2 $w.checks.sep $w.checks.c3 $w.checks.c4 \ + -fill x -pady 1.5p + +## Set up the radiobutton group +ttk::labelframe $w.radios -text "Radiobuttons" +ttk::radiobutton $w.radios.r1 -text "Great" -variable happiness -value great +ttk::radiobutton $w.radios.r2 -text "Good" -variable happiness -value good +ttk::radiobutton $w.radios.r3 -text "OK" -variable happiness -value ok +ttk::radiobutton $w.radios.r4 -text "Poor" -variable happiness -value poor +ttk::radiobutton $w.radios.r5 -text "Awful" -variable happiness -value awful +pack $w.radios.r1 $w.radios.r2 $w.radios.r3 $w.radios.r4 $w.radios.r5 \ + -fill x -padx 3p -pady 1.5p + +## Helper procedure for the toggleswitch proc setState {rootWidget exceptThese value} { if {$rootWidget in $exceptThese} { return @@ -50,35 +72,23 @@ proc setState {rootWidget exceptThese value} { } } -## Set up the checkbutton group -ttk::labelframe $w.checks -text "Checkbuttons" -ttk::checkbutton $w.checks.e -text Enabled -variable enabled -command { - setState .ttkbut .ttkbut.checks.e \ +## Set up the labelframe containing a label and a toggleswitch +ttk::labelframe $w.toggle -text Toggleswitch +ttk::label $w.toggle.l -text "Enable/disable widgets" +ttk::toggleswitch $w.toggle.sw -variable enabled -command { + setState $w [list $w.toggle $w.toggle.l $w.toggle.sw] \ [expr {$enabled ? "!disabled" : "disabled"}] } set enabled 1 ## See ttk_widget(n) for other possible state flags -ttk::separator $w.checks.sep1 -ttk::checkbutton $w.checks.c1 -text Cheese -variable cheese -ttk::checkbutton $w.checks.c2 -text Tomato -variable tomato -ttk::separator $w.checks.sep2 -ttk::checkbutton $w.checks.c3 -text Basil -variable basil -ttk::checkbutton $w.checks.c4 -text Oregano -variable oregano -pack $w.checks.e $w.checks.sep1 $w.checks.c1 $w.checks.c2 $w.checks.sep2 \ - $w.checks.c3 $w.checks.c4 -fill x -pady 1.5p - -## Set up the radiobutton group -ttk::labelframe $w.radios -text "Radiobuttons" -ttk::radiobutton $w.radios.r1 -text "Great" -variable happiness -value great -ttk::radiobutton $w.radios.r2 -text "Good" -variable happiness -value good -ttk::radiobutton $w.radios.r3 -text "OK" -variable happiness -value ok -ttk::radiobutton $w.radios.r4 -text "Poor" -variable happiness -value poor -ttk::radiobutton $w.radios.r5 -text "Awful" -variable happiness -value awful -pack $w.radios.r1 $w.radios.r2 $w.radios.r3 $w.radios.r4 $w.radios.r5 \ - -fill x -padx 3p -pady 1.5p +pack $w.toggle.sw -side right -padx 3p -pady 1.5p +pack $w.toggle.l -side left -padx 3p -pady 1.5p ## Arrange things neatly pack [ttk::frame $w.f] -fill both -expand 1 lower $w.f grid $w.buttons $w.checks $w.radios -in $w.f -sticky nwe -pady 1.5p -padx 3p +grid $w.toggle -in $w.f -column 1 -columnspan 2 -sticky nwe -pady 1.5p -padx 3p +grid configure $w.buttons -rowspan 2 grid columnconfigure $w.f {0 1 2} -weight 1 -uniform yes +grid rowconfigure $w.f 1 -weight 1 diff --git a/library/menu.tcl b/library/menu.tcl index 50319ef..15058f4 100644 --- a/library/menu.tcl +++ b/library/menu.tcl @@ -891,7 +891,7 @@ proc ::tk::MenuNextEntry {menu count} { proc ::tk::MenuFind {w char} { set char [string tolower $char] - set windowlist [winfo child $w] + set windowlist [winfo children $w] foreach child $windowlist { # Don't descend into other toplevels. @@ -925,8 +925,12 @@ proc ::tk::MenuFind {w char} { } switch -- [winfo class $child] { Menubutton { - set char2 [string index [$child cget -text] \ - [$child cget -underline]] + if {[$child cget -underline] < 0} { + set char2 "" + } else { + set char2 [string index [$child cget -text] \ + [$child cget -underline]] + } if {$char eq [string tolower $char2] || $char eq ""} { if {[$child cget -state] ne "disabled"} { return $child diff --git a/library/msgbox.tcl b/library/msgbox.tcl index cb39a1c..d2cbab6 100644 --- a/library/msgbox.tcl +++ b/library/msgbox.tcl @@ -422,13 +422,41 @@ proc ::tk::MessageBox {args} { # At <Destroy> the buttons have vanished, so must do this directly. bind $w.msg <Destroy> [list set tk::Priv.${disp}(button) $cancel] - # 7. Withdraw the window, then update all the geometry information + # 7. Limit window width by that of physical screen. + # On small screens the message widget's width may exceed the screen's + # width. In this case, change the message label's wrap length so the + # window fits on the physical screen. Tk Ticket e19f1d89 + set frameWidth [::tk::WMFrameWidth] + wm withdraw $w + update idletasks + if {[winfo reqwidth $w] + 2*$frameWidth > [winfo screenwidth $w]} { + # Calculate the wrap length as the screen width minus the + # width requested by the dialog without the message label and + # window decoration frame + set wraplength [expr {[winfo screenwidth $w] - 2*$frameWidth + - ([winfo reqwidth $w] - [winfo reqwidth $w.msg])}] + # Make sure that the wrap length is no less than the width + # of 20 average-size characters in the message label's font + set msgFont [$w.msg cget -font] + set str [string repeat "0" 20] + set minWraplength [font measure $msgFont -displayof $w $str] + if {$wraplength < $minWraplength} { ;# this is rather unprobable + set wraplength $minWraplength + } + # Apply the wrap length + $w.msg configure -wraplength $wraplength + if {[winfo exists $w.dtl]} { + $w.dtl configure -wraplength $wraplength + } + } + + # 8. Withdraw the window, then update all the geometry information # so we know how big it wants to be, then center the window in the # display (Motif style) and de-iconify it. ::tk::PlaceWindow $w widget $data(-parent) - # 8. Set a grab and claim the focus too. + # 9. Set a grab and claim the focus too. if {$data(-default) ne ""} { set focus $w.$data(-default) @@ -437,7 +465,7 @@ proc ::tk::MessageBox {args} { } ::tk::SetFocusGrab $w $focus - # 9. Wait for the user to respond, then restore the focus and + # 10. Wait for the user to respond, then restore the focus and # return the index of the selected button. Restore the focus # before deleting the window, since otherwise the window manager # may take the focus away so we can't redirect it. Finally, diff --git a/library/tclIndex b/library/tclIndex index 9b5f889..b769551 100644 --- a/library/tclIndex +++ b/library/tclIndex @@ -79,6 +79,7 @@ set auto_index(tk_focusNext) [list source [file join $dir focus.tcl]] set auto_index(tk_focusPrev) [list source [file join $dir focus.tcl]] set auto_index(::tk::FocusOK) [list source [file join $dir focus.tcl]] set auto_index(tk_focusFollowsMouse) [list source [file join $dir focus.tcl]] +set auto_index(::tk::fontchooser) [list source [file join $dir fontchooser.tcl]] set auto_index(::tk::IconList) [list source [file join $dir iconlist.tcl]] set auto_index(::tk::ListboxBeginSelect) [list source [file join $dir listbox.tcl]] set auto_index(::tk::ListboxMotion) [list source [file join $dir listbox.tcl]] @@ -249,4 +250,3 @@ set auto_index(::tk::ListBoxKeyAccel_Unset) [list source [file join $dir xmfbox. set auto_index(::tk::ListBoxKeyAccel_Key) [list source [file join $dir xmfbox.tcl]] set auto_index(::tk::ListBoxKeyAccel_Goto) [list source [file join $dir xmfbox.tcl]] set auto_index(::tk::ListBoxKeyAccel_Reset) [list source [file join $dir xmfbox.tcl]] -set auto_index(::tk::fontchooser) [list source [file join $dir fontchooser.tcl]] diff --git a/library/tk.tcl b/library/tk.tcl index 98b4608..dc7be05 100644 --- a/library/tk.tcl +++ b/library/tk.tcl @@ -11,7 +11,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. # Verify that we have Tk binary and script components from the same release -package require -exact tk 9.1a0 +package require -exact tk 9.1a1 # Create a ::tk namespace namespace eval ::tk { @@ -83,16 +83,35 @@ catch {tk useinputmethods 1} proc ::tk::PlaceWindow {w {place ""} {anchor ""}} { wm withdraw $w update idletasks + + set screenWidth [winfo screenwidth $w] + set screenHeight [winfo screenheight $w] + set width [winfo reqwidth $w] + set height [winfo reqheight $w] + ## "wm geometry" operates in window manager coordinates and thus includes + ## a possible decoration frame and the title bar. + set frameWidth [WMFrameWidth] + set titleHeight [WMTitleHeight] + set constrain 0 + if {$width + 2*$frameWidth > $screenWidth} { + set width [expr {$screenWidth - 2*$frameWidth}] + set constrain 1 + } + if {$height + $titleHeight + $frameWidth > $screenHeight} { + set height [expr {$screenHeight - $titleHeight - $frameWidth}] + set constrain 1 + } + set checkBounds 1 if {$place eq ""} { - set x [expr {([winfo screenwidth $w]-[winfo reqwidth $w])/2}] - set y [expr {([winfo screenheight $w]-[winfo reqheight $w])/2}] + set x [expr {($screenWidth - $width)/2}] + set y [expr {($screenHeight - $height)/2}] set checkBounds 0 } elseif {[string equal -length [string length $place] $place "pointer"]} { ## place at POINTER (centered if $anchor == center) if {[string equal -length [string length $anchor] $anchor "center"]} { - set x [expr {[winfo pointerx $w]-[winfo reqwidth $w]/2}] - set y [expr {[winfo pointery $w]-[winfo reqheight $w]/2}] + set x [expr {[winfo pointerx $w] - $width/2}] + set y [expr {[winfo pointery $w] - $height/2}] } else { set x [winfo pointerx $w] set y [winfo pointery $w] @@ -100,35 +119,48 @@ proc ::tk::PlaceWindow {w {place ""} {anchor ""}} { } elseif {[string equal -length [string length $place] $place "widget"] && \ [winfo exists $anchor] && [winfo ismapped $anchor]} { ## center about WIDGET $anchor, widget must be mapped - set x [expr {[winfo rootx $anchor] + \ - ([winfo width $anchor]-[winfo reqwidth $w])/2}] - set y [expr {[winfo rooty $anchor] + \ - ([winfo height $anchor]-[winfo reqheight $w])/2}] + set x [expr {[winfo rootx $anchor] + + ([winfo width $anchor] - $width)/2}] + set y [expr {[winfo rooty $anchor] + + ([winfo height $anchor] - $height)/2}] } else { - set x [expr {([winfo screenwidth $w]-[winfo reqwidth $w])/2}] - set y [expr {([winfo screenheight $w]-[winfo reqheight $w])/2}] + set x [expr {($screenWidth - $width)/2}] + set y [expr {($screenHeight - $height)/2}] set checkBounds 0 } + if {$checkBounds} { - if {$x < [winfo vrootx $w]} { - set x [winfo vrootx $w] - } elseif {$x > ([winfo vrootx $w]+[winfo vrootwidth $w]-[winfo reqwidth $w])} { - set x [expr {[winfo vrootx $w]+[winfo vrootwidth $w]-[winfo reqwidth $w]}] + set vrootX [winfo vrootx $w]; set vrootWidth [winfo vrootwidth $w] + if {$x + $width + $frameWidth > $vrootX + $vrootWidth} { + set x [expr {$vrootX + $vrootWidth - $width - $frameWidth}] + } + if {$x < $vrootX + $frameWidth} { + set x [expr {$vrootX + $frameWidth}] } - if {$y < [winfo vrooty $w]} { - set y [winfo vrooty $w] - } elseif {$y > ([winfo vrooty $w]+[winfo vrootheight $w]-[winfo reqheight $w])} { - set y [expr {[winfo vrooty $w]+[winfo vrootheight $w]-[winfo reqheight $w]}] + + set vrootY [winfo vrooty $w]; set vrootHeight [winfo vrootheight $w] + if {$y + $height + $frameWidth > $vrootY + $vrootHeight} { + set y [expr {$vrootY + $vrootHeight - $height - $frameWidth}] } + if {$y < $vrootY + $titleHeight} { + set y [expr {$vrootY + $titleHeight}] + } + if {[tk windowingsystem] eq "aqua"} { # Avoid the native menu bar which sits on top of everything. - if {$y < 22} { - set y 22 + if {$y < 22 + $titleHeight} { + set y [expr {22 + $titleHeight}] } } } + wm maxsize $w [winfo vrootwidth $w] [winfo vrootheight $w] - wm geometry $w +$x+$y + ## Set geometry and show window + set geom [expr {$constrain ? "${width}x${height}" : ""}] + incr x -$frameWidth + incr y -$titleHeight + append geom +$x+$y + wm geometry $w $geom wm deiconify $w } @@ -379,11 +411,8 @@ switch -exact -- [tk windowingsystem] { event add <<Cut>> <Control-x> <F20> <Control-Lock-X> event add <<Copy>> <Control-c> <F16> <Control-Lock-C> event add <<Paste>> <Control-v> <F18> <Control-Lock-V> - event add <<Undo>> <Control-z> <Control-Lock-Z> - event add <<Redo>> <Control-Z> <Control-Lock-z> - # On Darwin/Aqua, buttons from left to right are 1,3,2. On Darwin/X11 with recent - # XQuartz as the X server, they are 1,2,3; other X servers may differ. - + event add <<Undo>> <Control-z> <Control-Lock-Z> <Undo> + event add <<Redo>> <Control-Z> <Control-Lock-z> <Redo> event add <<SelectAll>> <Control-/> event add <<SelectNone>> <Control-backslash> event add <<NextChar>> <Right> @@ -415,6 +444,11 @@ switch -exact -- [tk windowingsystem] { # This is needed for XFree86 systems catch { event add <<PrevWindow>> <ISO_Left_Tab> } + catch { + event add <<Cut>> <XF86Cut> + event add <<Copy>> <XF86Copy> + event add <<Paste>> <XF86Paste> + } # This seems to be correct on *some* HP systems. catch { event add <<PrevWindow>> <hpBackTab> } @@ -425,11 +459,11 @@ switch -exact -- [tk windowingsystem] { set ::tk::AlwaysShowSelection 1 } "win32" { - event add <<Cut>> <Control-x> <Shift-Delete> <Control-Lock-X> - event add <<Copy>> <Control-c> <Control-Insert> <Control-Lock-C> - event add <<Paste>> <Control-v> <Shift-Insert> <Control-Lock-V> - event add <<Undo>> <Control-z> <Control-Lock-Z> - event add <<Redo>> <Control-y> <Control-Lock-Y> + event add <<Cut>> <Control-x> <Shift-Delete> <Control-Lock-X> <XF86Cut> + event add <<Copy>> <Control-c> <Control-Insert> <Control-Lock-C> <XF86Copy> + event add <<Paste>> <Control-v> <Shift-Insert> <Control-Lock-V> <XF86Paste> + event add <<Undo>> <Control-z> <Control-Lock-Z> <Undo> + event add <<Redo>> <Control-y> <Control-Lock-Y> <Redo> event add <<SelectAll>> <Control-/> <Control-a> <Control-Lock-A> event add <<SelectNone>> <Control-backslash> @@ -456,16 +490,16 @@ switch -exact -- [tk windowingsystem] { event add <<ToggleSelection>> <Control-Button-1> } "aqua" { - event add <<Cut>> <Command-x> <F2> <Command-Lock-X> - event add <<Copy>> <Command-c> <F3> <Command-Lock-C> - event add <<Paste>> <Command-v> <F4> <Command-Lock-V> + event add <<Cut>> <Command-x> <F2> <Command-Lock-X> <XF86Cut> + event add <<Copy>> <Command-c> <F3> <Command-Lock-C> <XF86Copy> + event add <<Paste>> <Command-v> <F4> <Command-Lock-V> <XF86Paste> event add <<Clear>> <Clear> # Official bindings # See https://support.apple.com/en-us/HT201236 event add <<SelectAll>> <Command-a> - event add <<Undo>> <Command-Key-z> <Command-Lock-Key-Z> - event add <<Redo>> <Shift-Command-Key-z> <Shift-Command-Lock-Key-z> + event add <<Undo>> <Command-Key-z> <Command-Lock-Key-Z> <Undo> + event add <<Redo>> <Shift-Command-Key-z> <Shift-Command-Lock-Key-z> <Redo> event add <<NextChar>> <Right> <Control-Key-f> <Control-Lock-Key-F> event add <<SelectNextChar>> <Shift-Right> <Shift-Control-Key-F> <Shift-Control-Lock-Key-F> event add <<PrevChar>> <Left> <Control-Key-b> <Control-Lock-Key-B> @@ -692,10 +726,61 @@ proc ::tk::AltKeyInDialog {path key} { } } +# ::tk::WMFrameWidth -- +# Return window manager frame width if known, else 0. +# +proc ::tk::WMFrameWidth {} { + set frameWidth 0 + # In SDL2 Tk, the frame width is a number between 6 and 27, depending on + # the screen's DPI value. + if {[info exists ::tk::sdltk] && $::tk::sdltk} { + variable dpi + if {$dpi < 140} { + set frameWidth 6 + } elseif {$dpi < 190} { + set frameWidth 9 + } elseif {$dpi < 240} { + set frameWidth 12 + } elseif {$dpi < 320} { + set frameWidth 15 + } elseif {$dpi < 420} { + set frameWidth 21 + } else { + set frameWidth 27 + } + } + return $frameWidth +} + +# ::tk::WMTitleHeight -- +# Return window manager height of window title bar if known, else 0. +# +proc ::tk::WMTitleHeight {} { + set titleHeight 0 + # In SDL2 Tk, the title height is a number between 20 and 78, depending on + # the screen's DPI value. + if {[info exists ::tk::sdltk] && $::tk::sdltk} { + variable dpi + if {$dpi < 140} { + set titleHeight 20 + } elseif {$dpi < 190} { + set titleHeight 30 + } elseif {$dpi < 240} { + set titleHeight 38 + } elseif {$dpi < 320} { + set titleHeight 46 + } elseif {$dpi < 420} { + set titleHeight 60 + } else { + set titleHeight 78 + } + } + return $titleHeight +} + # ::tk::mcmaxamp -- # Replacement for mcmax, used for texts with "magic ampersand" in it. # - proc ::tk::mcmaxamp {args} { set maxlen 0 foreach arg $args { diff --git a/library/ttk/elements.tcl b/library/ttk/elements.tcl new file mode 100644 index 0000000..c1cd3e8 --- /dev/null +++ b/library/ttk/elements.tcl @@ -0,0 +1,1071 @@ +#============================================================================== +# elements.tcl - Copyright © 2025 Csaba Nemethi <csaba.nemethi@t-online.de> +# +# Contains procedures that create the Tglswitch*.trough and Tglswitch*.slider +# elements for the Toggleswitch* styles. +# +# Structure of the module: +# - Private helper procedures and data +# - Generic private procedures creating the elements for arbitrary themes +# - Private procedures creating the elements for a few built-in themes +# - Public procedures +#============================================================================== + +# Private helper procedures and data +# ================================== + +namespace eval ttk::toggleswitch {} + +#------------------------------------------------------------------------------ +# ttk::toggleswitch::Rgb2Hsv +# +# Converts the specified RGB value to HSV. The argument is assumed to be of +# the form "#RRGGBB". The return value is a list of the form {h s v}, where h +# in [0.0, 360.0) and s, v in [0.0, 100.0]. +#------------------------------------------------------------------------------ +proc ttk::toggleswitch::Rgb2Hsv rgb { + scan $rgb "#%02x%02x%02x" r g b + set r [expr {$r / 255.0}] + set g [expr {$g / 255.0}] + set b [expr {$b / 255.0}] + + set min [expr {min($r, $g, $b)}] + set max [expr {max($r, $g, $b)}] + set d [expr {$max - $min}] + + # Compute the saturation and value + set s [expr {$max == 0 ? 0 : 100 * $d / $max}] + set v [expr {100 * $max}] + + # Compute the hue + if {$d == 0} { + set h 0.0 + } elseif {$max == $r} { + set frac [expr {fmod(($g - $b) / $d, 6)}] + if {$frac < 0} { set frac [expr {$frac + 6}] } + set h [expr {60 * $frac}] + } elseif {$max == $g} { + set h [expr {60 * (($b - $r) / $d + 2)}] + } else { + set h [expr {60 * (($r - $g) / $d + 4)}] + } + + return [list $h $s $v] +} + +#------------------------------------------------------------------------------ +# ttk::toggleswitch::Hsv2Rgb +# +# Converts the specified HSV value to RGB. The arguments are assumed to fulfil +# the conditions: h in [0.0, 360.0) and s, v in [0.0, 100.0]. The return value +# is a color specification of the form "#RRGGBB". +#------------------------------------------------------------------------------ +proc ttk::toggleswitch::Hsv2Rgb {h s v} { + set s [expr {$s / 100.0}]; set v [expr {$v / 100.0}] + set c [expr {$s * $v}] ;# chroma + set h [expr {$h / 60.0}] ;# in [0.0, 6.0) + set x [expr {$c * (1 - abs(fmod($h, 2) - 1))}] ;# intermediate value + + switch [expr {int($h)}] { + 0 { set r $c; set g $x; set b 0 } + 1 { set r $x; set g $c; set b 0 } + 2 { set r 0; set g $c; set b $x } + 3 { set r 0; set g $x; set b $c } + 4 { set r $x; set g 0; set b $c } + 5 { set r $c; set g 0; set b $x } + } + + set m [expr {$v - $c}] ;# lightness adjustment + set r [expr {round(255 * ($r + $m))}] + set g [expr {round(255 * ($g + $m))}] + set b [expr {round(255 * ($b + $m))}] + + return [format "#%02x%02x%02x" $r $g $b] +} + +#------------------------------------------------------------------------------ +# ttk::toggleswitch::NormalizeColor +# +# Returns the representation of a given color in the form "#RRGGBB". +#------------------------------------------------------------------------------ +proc ttk::toggleswitch::NormalizeColor color { + lassign [winfo rgb . $color] r g b + return [format "#%02x%02x%02x" \ + [expr {$r >> 8}] [expr {$g >> 8}] [expr {$b >> 8}]] +} + +#------------------------------------------------------------------------------ +# ttk::toggleswitch::IsColorLight +# +# Checks whether a given color can be classified as light. +#------------------------------------------------------------------------------ +proc ttk::toggleswitch::IsColorLight color { + lassign [winfo rgb . $color] r g b + return [expr {5 * ($g >> 8) + 2 * ($r >> 8) + ($b >> 8) > 8 * 192}] +} + +interp alias {} ttk::toggleswitch::CreateImg \ + {} image create photo -format $::tk::svgFmt +interp alias {} ttk::toggleswitch::CreateElem {} ttk::style element create + +namespace eval ttk::toggleswitch { + variable troughData + set troughData(1) { +<svg width="32" height="16" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <rect x="0" y="0" width="32" height="16" rx="8" } + set troughData(2) { +<svg width="40" height="20" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <rect x="0" y="0" width="40" height="20" rx="10" } + set troughData(3) { +<svg width="48" height="24" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <rect x="0" y="0" width="48" height="24" rx="12" } + + variable sliderData + set sliderData(1) { +<svg width="16" height="12" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <circle cx="8" cy="6" r="6" } + set sliderData(2) { +<svg width="20" height="16" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <circle cx="10" cy="8" r="8" } + set sliderData(3) { +<svg width="24" height="20" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <circle cx="12" cy="10" r="10" } + + variable onAndroid [expr {[info exists ::tk::android] && $::tk::android}] + variable madeElements 0 +} + +# Generic private procedures creating the elements for arbitrary themes +# ===================================================================== + +#------------------------------------------------------------------------------ +# ttk::toggleswitch::CreateElements_genericLight +#------------------------------------------------------------------------------ +proc ttk::toggleswitch::CreateElements_genericLight {} { + variable troughData + variable sliderData + variable onAndroid + + set bg [ttk::style lookup . -background {} #d9d9d9] + scan [NormalizeColor $bg] "#%02x%02x%02x" r g b + set hasDarkerBg [expr {$r <= 0xd9 && $g <= 0xd9 && $b <= 0xd9}] + + set selBg [ttk::style lookup . -selectbackground {} #000000] + if {[IsColorLight $selBg]} { set selBg #4a6984 } + set selBg [NormalizeColor $selBg] + + foreach n {1 2 3} { + # troughOffImg + set imgData $troughData($n) + set fill [expr {$hasDarkerBg ? "#c3c3c3" : "#d3d3d3"}] + append imgData "fill='$fill'/>\n</svg>" + set troughOffImg [CreateImg -data $imgData] + + # troughOffActiveImg + set imgData $troughData($n) + set fill2 [expr {$hasDarkerBg ? "#b3b3b3" : "#c3c3c3"}] + set fill [expr {$onAndroid ? $fill : $fill2}] + append imgData "fill='$fill'/>\n</svg>" + set troughOffActiveImg [CreateImg -data $imgData] + + # troughOffPressedImg + set imgData $troughData($n) + set fill [expr {$hasDarkerBg ? "#a3a3a3" : "#b3b3b3"}] + append imgData "fill='$fill'/>\n</svg>" + set troughOffPressedImg [CreateImg -data $imgData] + + # troughOffDisabledImg + set imgData $troughData($n) + set fill [expr {$hasDarkerBg ? "#d1d1d1" : "#e1e1e1"}] + append imgData "fill='$fill'/>\n</svg>" + set troughOffDisabledImg [CreateImg -data $imgData] + + # troughOnImg + set imgData $troughData($n) + set fill $selBg + lassign [Rgb2Hsv $fill] h s v + set dv [expr {$v < 80 ? 10 : -10}] + append imgData "fill='$fill'/>\n</svg>" + set troughOnImg [CreateImg -data $imgData] + + # troughOnActiveImg + set imgData $troughData($n) + set v [expr {$v + $dv}] + set fill [expr {$onAndroid ? $fill : [Hsv2Rgb $h $s $v]}] + append imgData "fill='$fill'/>\n</svg>" + set troughOnActiveImg [CreateImg -data $imgData] + + # troughOnPressedImg + set imgData $troughData($n) + set v [expr {$v + $dv}] + append imgData "fill='[Hsv2Rgb $h $s $v]'/>\n</svg>" + set troughOnPressedImg [CreateImg -data $imgData] + + # troughOnDisabledImg + set imgData $troughData($n) + append imgData "fill='[Hsv2Rgb $h 33.3 100]'/>\n</svg>" + set troughOnDisabledImg [CreateImg -data $imgData] + + CreateElem Tglswitch$n.trough image [list $troughOffImg \ + {selected disabled} $troughOnDisabledImg \ + {selected pressed} $troughOnPressedImg \ + {selected active} $troughOnActiveImg \ + selected $troughOnImg \ + disabled $troughOffDisabledImg \ + pressed $troughOffPressedImg \ + active $troughOffActiveImg \ + ] + + # sliderImg + set imgData $sliderData($n) + append imgData "fill='#ffffff'/>\n</svg>" + set sliderImg [CreateImg -data $imgData] + + CreateElem Tglswitch$n.slider image $sliderImg + } +} + +#------------------------------------------------------------------------------ +# ttk::toggleswitch::CreateElements_genericDark +#------------------------------------------------------------------------------ +proc ttk::toggleswitch::CreateElements_genericDark {} { + variable troughData + variable sliderData + variable onAndroid + + set selBg [ttk::style lookup . -selectbackground {} #000000] + if {[IsColorLight $selBg]} { set selBg #4a6984 } + set selBg [NormalizeColor $selBg] + + foreach n {1 2 3} { + # troughOffImg + set imgData $troughData($n) + set fill "#585858" + append imgData "fill='$fill'/>\n</svg>" + set troughOffImg [CreateImg -data $imgData] + + # troughOffActiveImg + set imgData $troughData($n) + set fill [expr {$onAndroid ? $fill : "#676767"}] + append imgData "fill='$fill'/>\n</svg>" + set troughOffActiveImg [CreateImg -data $imgData] + + # troughOffPressedImg + set imgData $troughData($n) + append imgData "fill='#787878'/>\n</svg>" + set troughOffPressedImg [CreateImg -data $imgData] + + # troughOffDisabledImg + set imgData $troughData($n) + append imgData "fill='#4a4a4a'/>\n</svg>" + set troughOffDisabledImg [CreateImg -data $imgData] + + # troughOnImg + set imgData $troughData($n) + set fill $selBg + lassign [Rgb2Hsv $fill] h s v + set vOrig $v + set dv [expr {$v < 80 ? 10 : -10}] + append imgData "fill='$fill'/>\n</svg>" + set troughOnImg [CreateImg -data $imgData] + + # troughOnActiveImg + set imgData $troughData($n) + set v [expr {$v + $dv}] + set fill [expr {$onAndroid ? $fill : [Hsv2Rgb $h $s $v]}] + append imgData "fill='$fill'/>\n</svg>" + set troughOnActiveImg [CreateImg -data $imgData] + + # troughOnPressedImg + set imgData $troughData($n) + set v [expr {$v + $dv}] + append imgData "fill='[Hsv2Rgb $h $s $v]'/>\n</svg>" + set troughOnPressedImg [CreateImg -data $imgData] + + # troughOnDisabledImg + set imgData $troughData($n) + set v [expr {$vOrig - 10}] + if {$v < 0} { set v 0 } + append imgData "fill='[Hsv2Rgb $h $s $v]'/>\n</svg>" + set troughOnDisabledImg [CreateImg -data $imgData] + + CreateElem Tglswitch$n.trough image [list $troughOffImg \ + {selected disabled} $troughOnDisabledImg \ + {selected pressed} $troughOnPressedImg \ + {selected active} $troughOnActiveImg \ + selected $troughOnImg \ + disabled $troughOffDisabledImg \ + pressed $troughOffPressedImg \ + active $troughOffActiveImg \ + ] + + # sliderOffImg + set imgData $sliderData($n) + append imgData "fill='#d3d3d3'/>\n</svg>" + set sliderOffImg [CreateImg -data $imgData] + + # sliderOffDisabledImg + set imgData $sliderData($n) + append imgData "fill='#888888'/>\n</svg>" + set sliderOffDisabledImg [CreateImg -data $imgData] + + # sliderOnDisabledImg + set imgData $sliderData($n) + append imgData "fill='#9f9f9f'/>\n</svg>" + set sliderOnDisabledImg [CreateImg -data $imgData] + + # sliderImg + set imgData $sliderData($n) + append imgData "fill='#ffffff'/>\n</svg>" + set sliderImg [CreateImg -data $imgData] + + CreateElem Tglswitch$n.slider image [list $sliderOffImg \ + {selected disabled} $sliderOnDisabledImg \ + selected $sliderImg \ + disabled $sliderOffDisabledImg \ + pressed $sliderImg \ + active $sliderImg \ + ] + } +} + +# Private procedures creating the elements for a few built-in themes +# ================================================================== + +#------------------------------------------------------------------------------ +# ttk::toggleswitch::CreateElements_clam +#------------------------------------------------------------------------------ +proc ttk::toggleswitch::CreateElements_clam {} { + variable troughData + variable sliderData + variable onAndroid + + foreach n {1 2 3} { + # troughOffImg + set imgData $troughData($n) + set fill "#bab5ab" + append imgData "fill='$fill'/>\n</svg>" + set troughOffImg [CreateImg -data $imgData] + + # troughOffActiveImg + set imgData $troughData($n) + set fill [expr {$onAndroid ? $fill : "#aca79e"}] + append imgData "fill='$fill'/>\n</svg>" + set troughOffActiveImg [CreateImg -data $imgData] + + # troughOffPressedImg + set imgData $troughData($n) + append imgData "fill='#9e9a91'/>\n</svg>" + set troughOffPressedImg [CreateImg -data $imgData] + + # troughOffDisabledImg + set imgData $troughData($n) + append imgData "fill='#cfc9be'/>\n</svg>" + set troughOffDisabledImg [CreateImg -data $imgData] + + # troughOnImg + set imgData $troughData($n) + set fill [Hsv2Rgb 208 43.9 51.8] ;# #4a6984 + append imgData "fill='$fill'/>\n</svg>" + set troughOnImg [CreateImg -data $imgData] + + # troughOnActiveImg + set imgData $troughData($n) + set fill [expr {$onAndroid ? $fill : [Hsv2Rgb 208 43.9 61.8]}] + append imgData "fill='$fill'/>\n</svg>" + set troughOnActiveImg [CreateImg -data $imgData] + + # troughOnPressedImg + set imgData $troughData($n) + append imgData "fill='[Hsv2Rgb 208 43.9 71.8]'/>\n</svg>" + set troughOnPressedImg [CreateImg -data $imgData] + + # troughOnDisabledImg + set imgData $troughData($n) + append imgData "fill='[Hsv2Rgb 208 33.9 100]'/>\n</svg>" + set troughOnDisabledImg [CreateImg -data $imgData] + + CreateElem Tglswitch$n.trough image [list $troughOffImg \ + {selected disabled} $troughOnDisabledImg \ + {selected pressed} $troughOnPressedImg \ + {selected active} $troughOnActiveImg \ + selected $troughOnImg \ + disabled $troughOffDisabledImg \ + pressed $troughOffPressedImg \ + active $troughOffActiveImg \ + ] + + # sliderImg + set imgData $sliderData($n) + append imgData "fill='#ffffff'/>\n</svg>" + set sliderImg [CreateImg -data $imgData] + + CreateElem Tglswitch$n.slider image $sliderImg + } +} + +#------------------------------------------------------------------------------ +# ttk::toggleswitch::CreateElements_vista +#------------------------------------------------------------------------------ +proc ttk::toggleswitch::CreateElements_vista {} { + variable elemInfoArr + if {[info exists elemInfoArr(vista)]} { + return "" + } + + if {$::tcl_platform(osVersion) >= 11.0} { ;# Win 11+ + CreateElements_win11 + } else { ;# Win 10- + CreateElements_win10 + } + + foreach n {1 2 3} { + ttk::style layout Toggleswitch$n [list \ + Tglswitch.focus -sticky nswe -children [list \ + Tglswitch.padding -sticky nswe -children [list \ + Tglswitch$n.trough -sticky {} -children [list \ + Tglswitch$n.slider -side left -sticky {} + ] + ] + ] + ] + } + + set elemInfoArr(vista) 1 +} + +#------------------------------------------------------------------------------ +# ttk::toggleswitch::CreateElements_win11 +#------------------------------------------------------------------------------ +proc ttk::toggleswitch::CreateElements_win11 {} { + set troughOffData(1) { +<svg width="32" height="16" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <rect x="0.5" y="0.5" width="31" height="15" rx="7.5" } + set troughOffData(2) { +<svg width="40" height="20" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <rect x="0.5" y="0.5" width="39" height="19" rx="9.5" } + set troughOffData(3) { +<svg width="48" height="24" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <rect x="0.5" y="0.5" width="47" height="23" rx="11.5" } + + set troughOnData(1) { +<svg width="32" height="16" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <rect x="0" y="0" width="32" height="16" rx="8" } + set troughOnData(2) { +<svg width="40" height="20" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <rect x="0" y="0" width="40" height="20" rx="10" } + set troughOnData(3) { +<svg width="48" height="24" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <rect x="0" y="0" width="48" height="24" rx="12" } + + set sliderOffData(1) { +<svg width="16" height="10" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <circle cx="7" cy="5" r="4" } ;# margins L, R: 3, 5 + set sliderOffData(2) { +<svg width="20" height="14" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <circle cx="9" cy="7" r="6" } ;# margins L, R: 3, 5 + set sliderOffData(3) { +<svg width="24" height="18" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <circle cx="11" cy="9" r="8" } ;# margins L, R: 3, 5 + + set sliderOnData(1) { +<svg width="16" height="10" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <circle cx="9" cy="5" r="4" } ;# margins L, R: 5, 3 + set sliderOnData(2) { +<svg width="20" height="14" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <circle cx="11" cy="7" r="6" } ;# margins L, R: 5, 3 + set sliderOnData(3) { +<svg width="24" height="18" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <circle cx="13" cy="9" r="8" } ;# margins L, R: 5, 3 + + set sliderActiveData(1) { +<svg width="16" height="10" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <circle cx="8" cy="5" r="5" } ;# margins L, R: 3, 3 + set sliderActiveData(2) { +<svg width="20" height="14" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <circle cx="10" cy="7" r="7" } ;# margins L, R: 3, 3 + set sliderActiveData(3) { +<svg width="24" height="18" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <circle cx="12" cy="9" r="9" } ;# margins L, R: 3, 3 + + set sliderOffPressedData(1) { +<svg width="16" height="10" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <rect x="3" y="0" width="13" height="10" rx="5" } ;# margins L, R: 3, 0 + set sliderOffPressedData(2) { +<svg width="20" height="14" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <rect x="3" y="0" width="17" height="14" rx="7" } ;# margins L, R: 3, 0 + set sliderOffPressedData(3) { +<svg width="24" height="18" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <rect x="3" y="0" width="21" height="18" rx="9" } ;# margins L, R: 3, 0 + + set sliderOnPressedData(1) { +<svg width="16" height="10" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <rect x="0" y="0" width="13" height="10" rx="5" } ;# margins L, R: 0, 3 + set sliderOnPressedData(2) { +<svg width="20" height="14" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <rect x="0" y="0" width="17" height="14" rx="7" } ;# margins L, R: 0, 3 + set sliderOnPressedData(3) { +<svg width="24" height="18" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <rect x="0" y="0" width="21" height="18" rx="9" } ;# margins L, R: 0, 3 + + foreach n {1 2 3} { + # troughOffImg + set imgData $troughOffData($n) + append imgData "fill='#f6f6f6' stroke='#8a8a8a'/>\n</svg>" + set troughOffImg [CreateImg -data $imgData] + + # troughOffActiveImg + set imgData $troughOffData($n) + append imgData "fill='#ededed' stroke='#878787'/>\n</svg>" + set troughOffActiveImg [CreateImg -data $imgData] + + # troughOffPressedImg + set imgData $troughOffData($n) + append imgData "fill='#e4e4e4' stroke='#858585'/>\n</svg>" + set troughOffPressedImg [CreateImg -data $imgData] + + # troughOffDisabledImg + set imgData $troughOffData($n) + append imgData "fill='#fbfbfb' stroke='#c5c5c5'/>\n</svg>" + set troughOffDisabledImg [CreateImg -data $imgData] + + # troughOnImg + set imgData $troughOnData($n) + append imgData "fill='#005fb8'/>\n</svg>" + set troughOnImg [CreateImg -data $imgData] + + # troughOnActiveImg + set imgData $troughOnData($n) + append imgData "fill='#196ebf'/>\n</svg>" + set troughOnActiveImg [CreateImg -data $imgData] + + # troughOnPressedImg + set imgData $troughOnData($n) + append imgData "fill='#327ec5'/>\n</svg>" + set troughOnPressedImg [CreateImg -data $imgData] + + # troughOnDisabledImg + set imgData $troughOnData($n) + append imgData "fill='#c5c5c5'/>\n</svg>" + set troughOnDisabledImg [CreateImg -data $imgData] + + CreateElem Tglswitch$n.trough image [list $troughOffImg \ + {selected disabled} $troughOnDisabledImg \ + {selected pressed} $troughOnPressedImg \ + {selected active} $troughOnActiveImg \ + selected $troughOnImg \ + disabled $troughOffDisabledImg \ + pressed $troughOffPressedImg \ + active $troughOffActiveImg \ + ] + + # sliderOffImg + set imgData $sliderOffData($n) + append imgData "fill='#5d5d5d'/>\n</svg>" + set sliderOffImg [CreateImg -data $imgData] + + # sliderOffActiveImg + set imgData $sliderActiveData($n) + append imgData "fill='#5a5a5a'/>\n</svg>" + set sliderOffActiveImg [CreateImg -data $imgData] + + # sliderOffPressedImg + set imgData $sliderOffPressedData($n) + append imgData "fill='#575757'/>\n</svg>" + set sliderOffPressedImg [CreateImg -data $imgData] + + # sliderOffDisabledImg + set imgData $sliderOffData($n) + append imgData "fill='#a1a1a1'/>\n</svg>" + set sliderOffDisabledImg [CreateImg -data $imgData] + + # sliderOnImg + set imgData $sliderOnData($n) + append imgData "fill='#ffffff'/>\n</svg>" + set sliderOnImg [CreateImg -data $imgData] + + # sliderOnActiveImg + set imgData $sliderActiveData($n) + append imgData "fill='#ffffff'/>\n</svg>" + set sliderOnActiveImg [CreateImg -data $imgData] + + # sliderOnPressedImg + set imgData $sliderOnPressedData($n) + append imgData "fill='#ffffff'/>\n</svg>" + set sliderOnPressedImg [CreateImg -data $imgData] + + # sliderOnDisabledImg + set imgData $sliderOnData($n) + append imgData "fill='#ffffff'/>\n</svg>" + set sliderOnDisabledImg [CreateImg -data $imgData] + + CreateElem Tglswitch$n.slider image [list $sliderOffImg \ + {selected disabled} $sliderOnDisabledImg \ + {selected pressed} $sliderOnPressedImg \ + {selected active} $sliderOnActiveImg \ + selected $sliderOnImg \ + disabled $sliderOffDisabledImg \ + pressed $sliderOffPressedImg \ + active $sliderOffActiveImg \ + ] + } +} + +#------------------------------------------------------------------------------ +# ttk::toggleswitch::CreateElements_win10 +#------------------------------------------------------------------------------ +proc ttk::toggleswitch::CreateElements_win10 {} { + set troughOffData(1) { +<svg width="35" height="16" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <rect x="1" y="1" width="33" height="14" rx="7" stroke-width="2" } + set troughOffData(2) { +<svg width="44" height="20" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <rect x="1" y="1" width="42" height="18" rx="9" stroke-width="2" } + set troughOffData(3) { +<svg width="53" height="24" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <rect x="1" y="1" width="51" height="22" rx="11" stroke-width="2" } + + set troughOnData(1) { +<svg width="35" height="16" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <rect x="0" y="0" width="35" height="16" rx="8" } + set troughOnData(2) { +<svg width="44" height="20" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <rect x="0" y="0" width="44" height="20" rx="10" } + set troughOnData(3) { +<svg width="53" height="24" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <rect x="0" y="0" width="53" height="24" rx="12" } + + set troughPressedData(1) { +<svg width="35" height="16" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <rect x="0" y="0" width="35" height="16" rx="8" fill="#666666"/> +</svg>} + set troughPressedData(2) { +<svg width="44" height="20" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <rect x="0" y="0" width="44" height="20" rx="10" fill="#666666"/> +</svg>} + set troughPressedData(3) { +<svg width="53" height="24" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <rect x="0" y="0" width="53" height="24" rx="12" fill="#666666"/> +</svg>} + + set sliderData(1) { +<svg width="16" height="8" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <circle cx="8" cy="4" r="4" } + set sliderData(2) { +<svg width="20" height="10" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <circle cx="10" cy="5" r="5" } + set sliderData(3) { +<svg width="24" height="12" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <circle cx="12" cy="6" r="6" } + + foreach n {1 2 3} { + # troughOffImg + set imgData $troughOffData($n) + append imgData "fill='#ffffff' stroke='#333333'/>\n</svg>" + set troughOffImg [CreateImg -data $imgData] + + # troughOffDisabledImg + set imgData $troughOffData($n) + append imgData "fill='#ffffff' stroke='#999999'/>\n</svg>" + set troughOffDisabledImg [CreateImg -data $imgData] + + # troughOnImg + set imgData $troughOnData($n) + append imgData "fill='#0078d7'/>\n</svg>" + set troughOnImg [CreateImg -data $imgData] + + # troughOnActiveImg + set imgData $troughOnData($n) + append imgData "fill='#4da1e3'/>\n</svg>" + set troughOnActiveImg [CreateImg -data $imgData] + + # troughOnDisabledImg + set imgData $troughOnData($n) + append imgData "fill='#cccccc'/>\n</svg>" + set troughOnDisabledImg [CreateImg -data $imgData] + + # troughPressedImg + set troughPressedImg [CreateImg -data $troughPressedData($n)] + + CreateElem Tglswitch$n.trough image [list $troughOffImg \ + {selected disabled} $troughOnDisabledImg \ + {selected pressed} $troughPressedImg \ + {selected active} $troughOnActiveImg \ + selected $troughOnImg \ + disabled $troughOffDisabledImg \ + pressed $troughPressedImg \ + ] + + # sliderOffImg + set imgData $sliderData($n) + append imgData "fill='#333333'/>\n</svg>" + set sliderOffImg [CreateImg -data $imgData] + + # sliderOffDisabledImg + set imgData $sliderData($n) + append imgData "fill='#999999'/>\n</svg>" + set sliderOffDisabledImg [CreateImg -data $imgData] + + # sliderOnImg + set imgData $sliderData($n) + append imgData "fill='#ffffff'/>\n</svg>" + set sliderOnImg [CreateImg -data $imgData] + + # sliderOnDisabledImg + set imgData $sliderData($n) + append imgData "fill='#a3a3a3'/>\n</svg>" + set sliderOnDisabledImg [CreateImg -data $imgData] + + # sliderPressedImg + set imgData $sliderData($n) + append imgData "fill='#ffffff'/>\n</svg>" + set sliderPressedImg [CreateImg -data $imgData] + + CreateElem Tglswitch$n.slider image [list $sliderOffImg \ + {selected disabled} $sliderOnDisabledImg \ + selected $sliderOnImg \ + disabled $sliderOffDisabledImg \ + pressed $sliderPressedImg \ + ] + } +} + +#------------------------------------------------------------------------------ +# ttk::toggleswitch::CreateElements_aqua +#------------------------------------------------------------------------------ +proc ttk::toggleswitch::CreateElements_aqua {} { + variable troughImgArr + variable sliderImgArr + + foreach n {1 2 3} { + foreach state {off offPressed offDisabled + on onPressed onDisabled onBg onDisabledBg} { + set troughImgArr(${state}$n) [CreateImg] + } + + CreateElem Tglswitch$n.trough image [list $troughImgArr(off$n) \ + {selected disabled background} $troughImgArr(onDisabledBg$n) \ + {selected disabled} $troughImgArr(onDisabled$n) \ + {selected background} $troughImgArr(onBg$n) \ + {selected pressed} $troughImgArr(onPressed$n) \ + selected $troughImgArr(on$n) \ + disabled $troughImgArr(offDisabled$n) \ + pressed $troughImgArr(offPressed$n) \ + ] + + foreach state {off offPressed offDisabled + on onPressed onDisabled} { + set sliderImgArr(${state}$n) [CreateImg] + } + + CreateElem Tglswitch$n.slider image [list $sliderImgArr(off$n) \ + {selected disabled} $sliderImgArr(onDisabled$n) \ + {selected pressed} $sliderImgArr(onPressed$n) \ + selected $sliderImgArr(on$n) \ + disabled $sliderImgArr(offDisabled$n) \ + pressed $sliderImgArr(offPressed$n) \ + ] + } + + UpdateElements_aqua +} + +#------------------------------------------------------------------------------ +# ttk::toggleswitch::UpdateElements_aqua +#------------------------------------------------------------------------------ +proc ttk::toggleswitch::UpdateElements_aqua {} { + variable troughImgArr + variable sliderImgArr + set darkMode [tk::unsupported::MacWindowStyle isdark .] + + set troughOffData(1) { +<svg width="26" height="15" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <rect x="0.5" y="0.5" width="25" height="14" rx="7" } + set troughOffData(2) { +<svg width="32" height="18" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <rect x="0.5" y="0.5" width="31" height="17" rx="8.5" } + set troughOffData(3) { +<svg width="38" height="22" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <rect x="0.5" y="0.5" width="37" height="21" rx="10.5" } + + set troughOnData(1) { +<svg width="26" height="15" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <rect x="0" y="0" width="26" height="15" rx="7.5" } + set troughOnData(2) { +<svg width="32" height="18" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <rect x="0" y="0" width="32" height="18" rx="9" } + set troughOnData(3) { +<svg width="38" height="22" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <rect x="0" y="0" width="38" height="22" rx="11" } + + set sliderOffData(1) { +<svg width="15" height="15" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <circle cx="7.5" cy="7.5" r="7" } + set sliderOffData(2) { +<svg width="18" height="18" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <circle cx="9" cy="9" r="8.5" } + set sliderOffData(3) { +<svg width="22" height="22" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <circle cx="11" cy="11" r="10.5" } + + set sliderOnData(1) { +<svg width="15" height="15" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <circle cx="7.5" cy="7.5" r="6.5" } + set sliderOnData(2) { +<svg width="18" height="18" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <circle cx="9" cy="9" r="8" } + set sliderOnData(3) { +<svg width="22" height="22" version="1.1" xmlns="http://www.w3.org/2000/svg"> + <circle cx="11" cy="11" r="10" } + + foreach n {1 2 3} { + # troughImgArr(off$n) + set imgData $troughOffData($n) + set fill [expr {$darkMode ? "#414141" : "#d9d9d9"}] + set strk [expr {$darkMode ? "#606060" : "#cdcdcd"}] + append imgData "fill='$fill' stroke='$strk'/>\n</svg>" + $troughImgArr(off$n) configure -data $imgData + + # troughImgArr(offPressed$n) + set imgData $troughOffData($n) + set fill [expr {$darkMode ? "#4d4d4d" : "#cbcbcb"}] + set strk [expr {$darkMode ? "#6a6a6a" : "#c0c0c0"}] + append imgData "fill='$fill' stroke='$strk'/>\n</svg>" + $troughImgArr(offPressed$n) configure -data $imgData + + # troughImgArr(offDisabled$n) + set imgData $troughOffData($n) + set fill [expr {$darkMode ? "#282828" : "#f4f4f4"}] + set strk [expr {$darkMode ? "#393939" : "#ededed"}] + append imgData "fill='$fill' stroke='$strk'/>\n</svg>" + $troughImgArr(offDisabled$n) configure -data $imgData + + # troughImgArr(on$n) + set imgData $troughOnData($n) + set fill [expr {$darkMode ? "systemSelectedContentBackgroundColor" + : "systemControlAccentColor"}] + set fill [NormalizeColor $fill] + if {$darkMode} { + # For the colors blue, purple, pink, red, orange, yellow, green, + # and graphite replace $fill with its counterpart for LightAqua + array set tmpArr { + #0059d1 #0064e1 #803482 #7d2a7e #c93379 #d93b86 + #d13539 #c4262b #c96003 #d96b0a #d19e00 #e1ac15 + #43932a #4da033 #696969 #808080 + + #0058d0 #007aff #7f3280 #953d96 #c83179 #f74f9e + #d03439 #e0383e #c86003 #f7821b #cd8f0e #fcb827 + #42912a #62ba46 #686868 #989898 + } + if {[info exists tmpArr($fill)]} { set fill $tmpArr($fill) } + array unset tmpArr + } + append imgData "fill='$fill'/>\n</svg>" + $troughImgArr(on$n) configure -data $imgData + + # troughImgArr(onPressed$n) + set imgData $troughOnData($n) + set fill [expr {$darkMode ? "systemControlAccentColor" + : "systemSelectedContentBackgroundColor"}] + set fill [NormalizeColor $fill] + if {$darkMode} { + # For the colors purple, red, yellow, and graphite + # replace $fill with its counterpart for LightAqua + array set tmpArr { + #a550a7 #953d96 #ff5257 #e0383e + #ffc600 #ffc726 #8c8c8c #989898 + + #a550a7 #7d2a7e #f74f9e #d93b85 + #fcb827 #de9e15 #8c8c8c #808080 + } + if {[info exists tmpArr($fill)]} { set fill $tmpArr($fill) } + array unset tmpArr + } + append imgData "fill='$fill'/>\n</svg>" + $troughImgArr(onPressed$n) configure -data $imgData + + # troughImgArr(onDisabled$n) + set imgData $troughOnData($n) + set fill [NormalizeColor systemSelectedControlColor] + append imgData "fill='$fill'/>\n</svg>" + $troughImgArr(onDisabled$n) configure -data $imgData + + # troughImgArr(onBg$n) + set imgData $troughOnData($n) + set fill [expr {$darkMode ? "#676665" : "#b0b0b0"}] + append imgData "fill='$fill'/>\n</svg>" + $troughImgArr(onBg$n) configure -data $imgData + + # troughImgArr(onDisabledBg$n) + set imgData $troughOnData($n) + set fill [expr {$darkMode ? "#282828" : "#f4f4f4"}] + append imgData "fill='$fill'/>\n</svg>" + $troughImgArr(onDisabledBg$n) configure -data $imgData + + # sliderImgArr(off$n) + set imgData $sliderOffData($n) + set fill [expr {$darkMode ? "#cacaca" : "#ffffff"}] + set strk [expr {$darkMode ? "#606060" : "#cdcdcd"}] + append imgData "fill='$fill' stroke='$strk'/>\n</svg>" + $sliderImgArr(off$n) configure -data $imgData + + # sliderImgArr(offPressed$n) + set imgData $sliderOffData($n) + set fill [expr {$darkMode ? "#e4e4e4" : "#f0f0f0"}] + set strk [expr {$darkMode ? "#6a6a6a" : "#c0c0c0"}] + append imgData "fill='$fill' stroke='$strk'/>\n</svg>" + $sliderImgArr(offPressed$n) configure -data $imgData + + # sliderImgArr(offDisabled$n) + set imgData $sliderOffData($n) + set fill [expr {$darkMode ? "#595959" : "#fdfdfd"}] + set strk [expr {$darkMode ? "#393939" : "#ededed"}] + append imgData "fill='$fill' stroke='$strk'/>\n</svg>" + $sliderImgArr(offDisabled$n) configure -data $imgData + + # sliderImgArr(on$n) + set imgData $sliderOnData($n) + set fill [expr {$darkMode ? "#cacaca" : "#ffffff"}] + append imgData "fill='$fill'/>\n</svg>" + $sliderImgArr(on$n) configure -data $imgData + + # sliderImgArr(onPressed$n) + set imgData $sliderOnData($n) + set fill [expr {$darkMode ? "#e4e4e4" : "#f0f0f0"}] + append imgData "fill='$fill'/>\n</svg>" + $sliderImgArr(onPressed$n) configure -data $imgData + + # sliderImgArr(onDisabled$n) + set imgData $sliderOnData($n) + set fill [expr {$darkMode ? "#595959" : "#fdfdfd"}] + append imgData "fill='$fill'/>\n</svg>" + $sliderImgArr(onDisabled$n) configure -data $imgData + + ttk::style layout Toggleswitch$n [list \ + Tglswitch.padding -sticky nswe -children [list \ + Tglswitch$n.trough -sticky {} -children [list \ + Tglswitch$n.slider -side left -sticky {} \ + ] + ] + ] + } +} + +# Public procedures +# ================= + +#------------------------------------------------------------------------------ +# ttk::toggleswitch::CreateElements +# +# Creates the Tglswitch*.trough and Tglswitch*.slider elements for the +# Toggleswitch* styles if they don't yet exist. Invoked by the procedures +# ttk::toggleswitch::CondMakeElements and ttk::toggleswitch::CondUpdateElements +# below. +#------------------------------------------------------------------------------ +proc ttk::toggleswitch::CreateElements {} { + set theme [ttk::style theme use] + + variable elemInfoArr + if {[info exists elemInfoArr($theme)]} { + if {$theme eq "aqua"} { + UpdateElements_$theme + } + + return "" + } + + switch $theme { + clam - vista - aqua { + CreateElements_$theme + } + winnative { + ttk::style theme settings vista { CreateElements_vista } + foreach n {1 2 3} { + CreateElem Tglswitch$n.trough from vista + CreateElem Tglswitch$n.slider from vista + } + } + default { + if {[llength [info commands CreateElements_$theme]] == 1} { + # The application can provide its own + # ttk::toggleswitch::CreateElements_$theme command. + # + CreateElements_$theme + } else { + set fg [ttk::style lookup . -foreground {} #000000] + if {[IsColorLight $fg]} { + CreateElements_genericDark + } else { + CreateElements_genericLight + } + } + } + } + set elemInfoArr($theme) 1 + + if {$theme eq "aqua"} { + foreach n {1 2 3} { + ttk::style layout Toggleswitch$n [list \ + Tglswitch.padding -sticky nswe -children [list \ + Tglswitch$n.trough -sticky {} -children [list \ + Tglswitch$n.slider -side left -sticky {} \ + ] + ] + ] + + if {[ttk::style lookup Toggleswitch$n -padding] eq ""} { + ttk::style configure Toggleswitch$n -padding 1.5p + } + } + } else { + foreach n {1 2 3} { + ttk::style layout Toggleswitch$n [list \ + Tglswitch.focus -sticky nswe -children [list \ + Tglswitch.padding -sticky nswe -children [list \ + Tglswitch$n.trough -sticky {} -children [list \ + Tglswitch$n.slider -side left -sticky {} + ] + ] + ] + ] + + if {[ttk::style lookup Toggleswitch$n -padding] eq ""} { + ttk::style configure Toggleswitch$n -padding 0.75p + } + if {$theme eq "classic" && + [ttk::style lookup Toggleswitch$n -focussolid] eq ""} { + ttk::style configure Toggleswitch$n -focussolid 1 + } + } + } +} + +#------------------------------------------------------------------------------ +# ttk::toggleswitch::CondMakeElements +# +# Creates the Tglswitch*.trough and Tglswitch*.slider elements for the +# Toggleswitch* styles if necessary. Invoked from within the C code, by the +# widget initialization hook. +#------------------------------------------------------------------------------ +proc ttk::toggleswitch::CondMakeElements {} { + variable madeElements + if {!$madeElements} { + CreateElements + set madeElements 1 + } +} + +#------------------------------------------------------------------------------ +# ttk::toggleswitch::CondUpdateElements +# +# Updates the Tglswitch*.trough and Tglswitch*.slider elements for the +# Toggleswitch* styles if necessary. Invoked from within the proc +# ttk::ThemeChanged (see ttk.tcl) and the C code for macOSX, after sending the +# virtual events <<LightAqua>>/<<DarkAqua>> and <<AppearanceChanged>>. +#------------------------------------------------------------------------------ +proc ttk::toggleswitch::CondUpdateElements {} { + variable madeElements + if {$madeElements} { ;# for some theme and appearance + CreateElements ;# for the new theme or appearance + } +} diff --git a/library/ttk/toggleswitch.tcl b/library/ttk/toggleswitch.tcl new file mode 100644 index 0000000..e195174 --- /dev/null +++ b/library/ttk/toggleswitch.tcl @@ -0,0 +1,191 @@ +# toggleswitch.tcl - Copyright © 2025 Csaba Nemethi <csaba.nemethi@t-online.de> +# +# Bindings for the ttk::toggleswitch widget. + +namespace eval ttk::toggleswitch { + variable State + set State(dragging) 0 + set State(moveState) idle ;# other values: moving, moved +} + +bind Toggleswitch <<ThemeChanged>> { ttk::toggleswitch::ThemeChanged %W } + +if {![info exists tk::android] || !$tk::android} { + bind Toggleswitch <Enter> { %W instate !disabled {%W state active} } + bind Toggleswitch <Leave> { %W state !active } +} +bind Toggleswitch <B1-Leave> { # Preserves the active state. } +bind Toggleswitch <Button-1> { ttk::toggleswitch::Press %W %x %y } +bind Toggleswitch <B1-Motion> { ttk::toggleswitch::Drag %W %x %y } +bind Toggleswitch <ButtonRelease-1> { ttk::toggleswitch::Release %W } +bind Toggleswitch <space> { ttk::toggleswitch::ToggleDelayed %W } + +proc ttk::toggleswitch::ThemeChanged w { + if {[info cmdtype $w] ne "native"} { + return "" ;# the widget was not created by the ttk::toggleswitch cmd + } + + set stateSpec [$w state !disabled] ;# needed for $w set + $w set [expr {[$w switchstate] ? [$w get max] : [$w get min]}] + $w state $stateSpec ;# restores the state +} + +proc ttk::toggleswitch::Press {w x y} { + $w instate disabled { + return "" + } + + $w state pressed + + variable State + array set State [list dragging 0 moveState idle startX $x prevX $x \ + prevElem [$w identify element $x $y]] +} + +proc ttk::toggleswitch::Drag {w x y} { + if {[$w instate disabled] || [$w instate !pressed]} { + return "" + } + + variable State + + if {[ttk::style theme use] eq "aqua"} { + if {$State(moveState) eq "moving"} { + return "" + } + + set curElem [$w identify element $x $y] + if {[string match "*.slider" $State(prevElem)] && + [string match "*.trough" $curElem]} { + StartToggling $w + } elseif {$x < 0} { + StartMovingLeft $w + } elseif {$x >= [winfo width $w]} { + StartMovingRight $w + } + + set State(prevElem) $curElem + } else { + if {!$State(dragging) && abs($x - $State(startX)) > [tk::ScaleNum 4]} { + set State(dragging) 1 + } + if {!$State(dragging)} { + return "" + } + + set curX [$w xcoord] + set newX [expr {$curX + $x - $State(prevX)}] + $w set [$w get $newX] + + set State(prevX) $x + } +} + +proc ttk::toggleswitch::Release w { + if {[$w instate disabled] || [$w instate !pressed]} { + return "" + } + + variable State + + if {$State(dragging)} { + $w switchstate [expr {[$w get] > [$w get max]/2}] + } elseif {[$w instate hover]} { + if {[ttk::style theme use] eq "aqua"} { + if {$State(moveState) eq "idle"} { + StartToggling $w + } + } else { + $w toggle + } + } + + $w state !pressed + set State(dragging) 0 +} + +proc ttk::toggleswitch::ToggleDelayed w { + if {[$w instate disabled] || [$w instate pressed]} { + return "" + } + + $w state pressed + after 200 [list ttk::toggleswitch::ToggleSwitchState $w] +} + +proc ttk::toggleswitch::StartToggling w { + if {[$w get] == [$w get max]} { + StartMovingLeft $w + } else { + StartMovingRight $w + } +} + +proc ttk::toggleswitch::StartMovingLeft w { + if {[$w get] == [$w get min]} { + return "" + } + + variable State + set State(moveState) moving + $w state !selected ;# will be undone before invoking switchstate + MoveLeft $w [$w get max] +} + +proc ttk::toggleswitch::MoveLeft {w val} { + if {![winfo exists $w] || [winfo class $w] ne "Toggleswitch"} { + return "" + } + + set val [expr {$val - 1}] + $w set $val + + if {$val > [$w get min]} { + after 10 [list ttk::toggleswitch::MoveLeft $w $val] + } else { + $w state selected ;# restores the original selected state + $w switchstate 0 + + variable State + set State(moveState) moved + } +} + +proc ttk::toggleswitch::StartMovingRight w { + if {[$w get] == [$w get max]} { + return "" + } + + variable State + set State(moveState) moving + $w state selected ;# will be undone before invoking switchstate + MoveRight $w [$w get min] +} + +proc ttk::toggleswitch::MoveRight {w val} { + if {![winfo exists $w] || [winfo class $w] ne "Toggleswitch"} { + return "" + } + + set val [expr {$val + 1}] + $w set $val + + if {$val < [$w get max]} { + after 10 [list ttk::toggleswitch::MoveRight $w $val] + } else { + $w state !selected ;# restores the original !selected state + $w switchstate 1 + + variable State + set State(moveState) moved + } +} + +proc ttk::toggleswitch::ToggleSwitchState w { + if {![winfo exists $w] || [winfo class $w] ne "Toggleswitch"} { + return "" + } + + $w toggle + $w state !pressed +} diff --git a/library/ttk/ttk.tcl b/library/ttk/ttk.tcl index e5bfc42..89876d9 100644 --- a/library/ttk/ttk.tcl +++ b/library/ttk/ttk.tcl @@ -15,6 +15,7 @@ namespace eval ::ttk { source -encoding utf-8 [file join $::ttk::library fonts.tcl] source -encoding utf-8 [file join $::ttk::library cursors.tcl] source -encoding utf-8 [file join $::ttk::library utils.tcl] +source -encoding utf-8 [file join $::ttk::library elements.tcl] ## ttk::deprecated $old $new -- # Define $old command as a deprecated alias for $new command @@ -57,6 +58,8 @@ package ifneeded tile 0.8.6 { package provide tile 0.8.6 } # Sends a <<ThemeChanged>> virtual event to all widgets. # proc ::ttk::ThemeChanged {} { + toggleswitch::CondUpdateElements ;# see elements.tcl + set Q . while {[llength $Q]} { set QN [list] @@ -142,6 +145,7 @@ proc ::ttk::setTreeviewRowHeight {} { # source -encoding utf-8 [file join $::ttk::library button.tcl] source -encoding utf-8 [file join $::ttk::library menubutton.tcl] +source -encoding utf-8 [file join $::ttk::library toggleswitch.tcl] source -encoding utf-8 [file join $::ttk::library scrollbar.tcl] source -encoding utf-8 [file join $::ttk::library scale.tcl] source -encoding utf-8 [file join $::ttk::library progress.tcl] @@ -173,7 +177,7 @@ proc ttk::LoadThemes {} { alt altTheme.tcl clam clamTheme.tcl winnative winTheme.tcl - xpnative {xpTheme.tcl vistaTheme.tcl} + vista vistaTheme.tcl aqua aquaTheme.tcl } { if {[lsearch -exact $builtinThemes $theme] >= 0} { @@ -190,14 +194,14 @@ ttk::LoadThemes; rename ::ttk::LoadThemes {} # # Notes: # + On OSX, aqua theme is the default -# + On Windows, xpnative takes precedence over winnative if available. +# + On Windows, vista takes precedence over winnative if available. # + On X11, users can use the X resource database to # specify a preferred theme (*TkTheme: themeName); # otherwise "default" is used. # proc ttk::DefaultTheme {} { - set preferred [list aqua vista xpnative winnative] + set preferred [list aqua vista winnative] set userTheme [option get . tkTheme TkTheme] if {$userTheme ne {} && ![catch { diff --git a/library/ttk/vistaTheme.tcl b/library/ttk/vistaTheme.tcl index 5a30837..d3d73f1 100644 --- a/library/ttk/vistaTheme.tcl +++ b/library/ttk/vistaTheme.tcl @@ -2,16 +2,6 @@ # Settings for Microsoft Windows Vista and Server 2008 # -# The Vista theme can only be defined on Windows Vista and above. The theme -# is created in C due to the need to assign a theme-enabled function for -# detecting when themeing is disabled. On systems that cannot support the -# Vista theme, there will be no such theme created and we must not -# evaluate this script. - -if {"vista" ni [ttk::style theme names]} { - return -} - namespace eval ttk::theme::vista { ttk::style theme settings vista { @@ -24,7 +14,7 @@ namespace eval ttk::theme::vista { -insertcolor SystemWindowText \ -font TkDefaultFont - ttk::style map "." -foreground {disabled SystemGrayText} + ttk::style map "." -foreground [list disabled SystemGrayText] ttk::style configure TButton -anchor center -padding 0.75p -width -11 ttk::style configure TRadiobutton -padding 1.5p @@ -222,8 +212,6 @@ namespace eval ttk::theme::vista { ttk::style configure Item -padding {3p 0 0 0} ttk::style configure Treeview -indent 15p ttk::setTreeviewRowHeight - - package provide ttk::theme::vista 1.0 } } diff --git a/library/ttk/xpTheme.tcl b/library/ttk/xpTheme.tcl deleted file mode 100644 index 60c47b0..0000000 --- a/library/ttk/xpTheme.tcl +++ /dev/null @@ -1,95 +0,0 @@ -# -# Settings for 'xpnative' theme -# - -namespace eval ttk::theme::xpnative { - - ttk::style theme settings xpnative { - - ttk::style configure . \ - -background SystemButtonFace \ - -foreground SystemWindowText \ - -selectforeground SystemHighlightText \ - -selectbackground SystemHighlight \ - -insertcolor SystemWindowText \ - -font TkDefaultFont - - ttk::style map "." -foreground [list disabled SystemGrayText] - - ttk::style configure TButton -anchor center -padding 0.75p -width -11 - ttk::style configure TRadiobutton -padding 1.5p - ttk::style configure TCheckbutton -padding 1.5p - ttk::style configure TMenubutton -padding {6p 3p} - - ttk::style configure TNotebook -tabmargins {2 2 2 0} - ttk::style map TNotebook.Tab -expand {selected {2 2 2 2}} - - ttk::style configure TLabelframe.Label -foreground "#0046d5" - - # OR: -padding {3 3 3 6}, which some apps seem to use. - ttk::style configure TEntry -padding {2 2 2 4} - ttk::style map TEntry \ - -selectbackground [list !focus SystemWindow] \ - -selectforeground [list !focus SystemWindowText] - ttk::style configure TCombobox -padding 1.5p - ttk::style map TCombobox \ - -selectbackground [list !focus SystemWindow] \ - -selectforeground [list !focus SystemWindowText] \ - -foreground [list \ - disabled SystemGrayText \ - {readonly focus} SystemHighlightText \ - ] \ - -focusfill [list {readonly focus} SystemHighlight] - - ttk::style configure TSpinbox -padding {1.5p 0 10.5p 0} - ttk::style map TSpinbox \ - -selectbackground [list !focus SystemWindow] \ - -selectforeground [list !focus SystemWindowText] - - ttk::style configure Toolbutton -padding 3p - - # Treeview: - ttk::style configure Heading -font TkHeadingFont -relief raised - ttk::style configure Item \ - -indicatormargins {1.5p 1.5p 3p 1.5p} - ttk::style configure Treeview -background SystemWindow \ - -stripedbackground System3dLight -indent 15p - ttk::setTreeviewRowHeight - ttk::style map Treeview \ - -background [list disabled SystemButtonFace \ - selected SystemHighlight] \ - -foreground [list disabled SystemGrayText \ - selected SystemHighlightText] - } -} - -# ttk::theme::xpnative::configureNotebookStyle -- -# -# Sets theme-specific option values for the ttk::notebook style $style and the -# style $style.Tab. Invoked by ::ttk::configureNotebookStyle. - -proc ttk::theme::xpnative::configureNotebookStyle {style} { - set tabPos [ttk::style lookup $style -tabposition {} nw] - switch -- [string index $tabPos 0] { - n { - ttk::style configure $style -tabmargins {2 2 2 0} - ttk::style map $style.Tab -expand {selected {2 2 2 2}} - } - s { - ttk::style configure $style -tabmargins {2 0 2 2} - ttk::style map $style.Tab -expand {selected {2 2 2 2}} - } - w { - ttk::style configure $style -tabmargins {2 2 0 2} - ttk::style map $style.Tab -expand {selected {2 2 2 2}} - } - e { - ttk::style configure $style -tabmargins {0 2 2 2} - ttk::style map $style.Tab -expand {selected {2 2 2 2}} - } - default { - ttk::style configure $style -tabmargins {2 2 2 0} - ttk::style map $style.Tab -expand {selected {2 2 2 2}} - } - } -} diff --git a/macosx/GNUmakefile b/macosx/GNUmakefile index 42c0067..8f87e55 100644 --- a/macosx/GNUmakefile +++ b/macosx/GNUmakefile @@ -272,14 +272,18 @@ else rm -rf Frameworks/Tcl.framework/{,/Versions/${TCL_VERSION}}/{Headers,PrivateHeaders,*_debug,lib*.a,*Config.sh} && \ rm -rf Frameworks/Tk.framework/{,/Versions/${VERSION}}/{Headers,PrivateHeaders,*_debug,lib*.a,*Config.sh} && \ fix_install_id ( ) { \ - chmod -RH a+w "$$1"; \ - install_name_tool -id $$(otool -L "$$1" | awk "/$$2\.framework.*[^:]\$$/ {sub(\"^.*/Frameworks\",\"@executable_path/../Frameworks\",\$$1); print \$$1}") "$$1"; \ - chmod -RH a-w "$$1"; \ + chmod -RH a+w "$$1"; \ + OLD=$$(otool -L "$$1" | awk "/$$2\\.framework.*[^:]\$$/ {print \$$1}"); \ + NEW=$$(echo "$$OLD" | sed "s|^.*/Frameworks|@executable_path/../Frameworks|"); \ + install_name_tool -id "$$NEW" "$$1"; \ + chmod -RH a-w "$$1"; \ } && \ fix_install_name ( ) { \ - chmod -RH a+w "$$1"; \ - install_name_tool -change $$(otool -L "$$1" | awk "/$$2\.framework.*[^:]\$$/ {print \$$1; sub(\"^.*/Frameworks\",\"@executable_path/../Frameworks\",\$$1); print \$$1}") "$$1"; \ - chmod -RH a-w "$$1"; \ + chmod -RH a+w "$$1"; \ + OLD=$$(otool -L "$$1" | awk "/$$2\\.framework.*[^:]\$$/ {print \$$1}"); \ + NEW=$$(echo "$$OLD" | sed "s|^.*/Frameworks|@executable_path/../Frameworks|"); \ + install_name_tool -change "$$OLD" "$$NEW" "$$1"; \ + chmod -RH a-w "$$1"; \ } && \ fix_install_id Frameworks/Tcl.framework/Tcl Tcl && fix_install_id Frameworks/Tk.framework/Tk Tk && \ fix_install_name MacOS/Wish Tcl && fix_install_name MacOS/Wish Tk diff --git a/macosx/Wish-Info.plist.in b/macosx/Wish-Info.plist.in index 32e9cda..8578da5 100644 --- a/macosx/Wish-Info.plist.in +++ b/macosx/Wish-Info.plist.in @@ -89,7 +89,7 @@ <key>OSAScriptingDefinition</key> <string>Wish.sdef</string> <key>NSHighResolutionCapable</key> - <string>True</string> + <true/> <key>NSServices</key> <array> <dict> diff --git a/macosx/tkMacOSX.h b/macosx/tkMacOSX.h index e80199b..dfaa4ad 100644 --- a/macosx/tkMacOSX.h +++ b/macosx/tkMacOSX.h @@ -29,6 +29,6 @@ typedef int (Tk_MacOSXEmbedMakeContainerExistProc) (Tk_Window window); typedef void (Tk_MacOSXEmbedGetClipProc) (Tk_Window window, void *rgn); typedef void (Tk_MacOSXEmbedGetOffsetInParentProc) (Tk_Window window, void *ulCorner); -#include "tkPlatDecls.h" +#include "tkPlatDecls.h" /* IWYU pragma: export */ #endif /* _TKMAC */ diff --git a/macosx/tkMacOSXBitmap.c b/macosx/tkMacOSXBitmap.c index 33b1960..1d4461d 100644 --- a/macosx/tkMacOSXBitmap.c +++ b/macosx/tkMacOSXBitmap.c @@ -361,7 +361,7 @@ TkMacOSXIconBitmapObjCmd( name = Tcl_GetStringFromObj(objv[i++], &len); if (!len) { Tcl_SetObjResult(interp, Tcl_NewStringObj("empty bitmap name", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "MACBITMAP", "BAD", NULL); + Tcl_SetErrorCode(interp, "TK", "MACBITMAP", "BAD", (char *)NULL); goto end; } if (Tcl_GetIntFromObj(interp, objv[i++], &ib.width) != TCL_OK) { @@ -377,7 +377,7 @@ TkMacOSXIconBitmapObjCmd( value = Tcl_GetStringFromObj(objv[i++], &len); if (!len) { Tcl_SetObjResult(interp, Tcl_NewStringObj("empty bitmap value", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "MACBITMAP", "EMPTY", NULL); + Tcl_SetErrorCode(interp, "TK", "MACBITMAP", "EMPTY", (char *)NULL); goto end; } #if 0 @@ -392,7 +392,7 @@ TkMacOSXIconBitmapObjCmd( if (len > 4) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "invalid bitmap value", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "MACBITMAP", "INVALID", NULL); + Tcl_SetErrorCode(interp, "TK", "MACBITMAP", "INVALID", (char *)NULL); goto end; } } diff --git a/macosx/tkMacOSXClipboard.c b/macosx/tkMacOSXClipboard.c index 8d5f727..c5c60e5 100644 --- a/macosx/tkMacOSXClipboard.c +++ b/macosx/tkMacOSXClipboard.c @@ -16,7 +16,7 @@ #include "tkSelect.h" static NSInteger changeCount = -1; -static Tk_Window clipboardOwner = NULL; +static Tk_Window tkClipboardOwner = NULL; #pragma mark TKApplication(TKClipboard) @@ -26,7 +26,6 @@ static Tk_Window clipboardOwner = NULL; provideDataForType: (NSString *) type { NSMutableString *string = [NSMutableString new]; - if (dispPtr && dispPtr->clipboardActive && [type isEqualToString:NSStringPboardType]) { for (TkClipboardTarget *targetPtr = dispPtr->clipTargetPtr; targetPtr; @@ -36,8 +35,8 @@ static Tk_Window clipboardOwner = NULL; for (TkClipboardBuffer *cbPtr = targetPtr->firstBufferPtr; cbPtr; cbPtr = cbPtr->nextPtr) { NSString *s = [[TKNSString alloc] - initWithTclUtfBytes:cbPtr->buffer - length:(NSUInteger)cbPtr->length]; + initWithTclUtfBytes:cbPtr->buffer + length:(NSUInteger)cbPtr->length]; [string appendString:s]; [s release]; } @@ -46,6 +45,7 @@ static Tk_Window clipboardOwner = NULL; } } [sender setString:string forType:type]; + changeCount = [sender changeCount]; [string release]; } @@ -61,26 +61,28 @@ static Tk_Window clipboardOwner = NULL; - (void) pasteboard: (NSPasteboard *) sender provideDataForType: (NSString *) type { - [self tkProvidePasteboard:TkGetDisplayList() pasteboard:sender - provideDataForType:type]; + TkDisplay *dispPtr = TkGetDisplayList(); + [self tkProvidePasteboard:dispPtr + pasteboard:[NSPasteboard generalPasteboard] + provideDataForType:NSStringPboardType]; } - (void) tkCheckPasteboard { - if (clipboardOwner && [[NSPasteboard generalPasteboard] changeCount] != + if (tkClipboardOwner && [[NSPasteboard generalPasteboard] changeCount] != changeCount) { TkDisplay *dispPtr = TkGetDisplayList(); if (dispPtr) { XEvent event; event.xany.type = SelectionClear; - event.xany.serial = NextRequest(Tk_Display(clipboardOwner)); + event.xany.serial = NextRequest(Tk_Display(tkClipboardOwner)); event.xany.send_event = False; - event.xany.window = Tk_WindowId(clipboardOwner); - event.xany.display = Tk_Display(clipboardOwner); + event.xany.window = Tk_WindowId(tkClipboardOwner); + event.xany.display = Tk_Display(tkClipboardOwner); event.xselectionclear.selection = dispPtr->clipboardAtom; Tk_QueueWindowEvent(&event, TCL_QUEUE_TAIL); } - clipboardOwner = NULL; + tkClipboardOwner = NULL; } } @end @@ -144,7 +146,7 @@ TkSelGetSelection( "%s selection doesn't exist or form \"%s\" not defined", Tk_GetAtomName(tkwin, selection), Tk_GetAtomName(tkwin, target))); - Tcl_SetErrorCode(interp, "TK", "SELECTION", "EXISTS", NULL); + Tcl_SetErrorCode(interp, "TK", "SELECTION", "EXISTS", (char *)NULL); } return result; } @@ -176,10 +178,9 @@ XSetSelectionOwner( TkDisplay *dispPtr = TkGetDisplayList(); if (dispPtr && selection == dispPtr->clipboardAtom) { - clipboardOwner = owner ? Tk_IdToWindow(display, owner) : NULL; + tkClipboardOwner = owner ? Tk_IdToWindow(display, owner) : NULL; if (!dispPtr->clipboardActive) { NSPasteboard *pb = [NSPasteboard generalPasteboard]; - changeCount = [pb declareTypes:[NSArray array] owner:NSApp]; } } @@ -198,7 +199,7 @@ XSetSelectionOwner( * None. * * Side effects: - * clipboardOwner is cleared. + * tkClipboardOwner is cleared. * *---------------------------------------------------------------------- */ @@ -207,8 +208,8 @@ void TkMacOSXSelDeadWindow( TkWindow *winPtr) { - if (winPtr && winPtr == (TkWindow *)clipboardOwner) { - clipboardOwner = NULL; + if (winPtr && winPtr == (TkWindow *)tkClipboardOwner) { + tkClipboardOwner = NULL; } } @@ -218,27 +219,63 @@ TkMacOSXSelDeadWindow( * TkSelUpdateClipboard -- * * This function is called to force the clipboard to be updated after new - * data is added. + * data is added or the clipboard has been cleared. + * + * The nil Object is declared to be the owner. This is done in a way + * which triggers an incremeent of the pasteboard's changeCount property, + * notifying clipboard managers that the value has changed. * * Results: * None. * * Side effects: - * None. + * Ownership contents and attributes of the general NSPasteboard + * may change. * *---------------------------------------------------------------------- */ +/* + * Apple says that the changeCount is incremented whenever the ownership + * of a pasteboard type changes. They actually mean that the changeCount + * is incremented when declareTypes is called, but is left unchanged when + * addTypes is called. (Both methods can change ownership in some sense + * and both return the new changeCount.) + * + * Apple also says that addTypes "promises" that the owner object (if not nil) + * will provide data of the specified type, while declareTypes "prepares" the + * pasteboard. Maybe that explains something. + */ + void TkSelUpdateClipboard( - TCL_UNUSED(TkWindow *), /* Window associated with clipboard. */ - TCL_UNUSED(TkClipboardTarget *)) - /* Info about the content. */ + TCL_UNUSED(TkWindow*), /* Window associated with clipboard. */ + clipboardOption option) /* option passed to clipboard command */ { NSPasteboard *pb = [NSPasteboard generalPasteboard]; + switch (option) { + case CLIPBOARD_APPEND: + /* + * This increments the changeCount so that clipboard managers will be + * able to see and manage the clip. + */ - changeCount = [pb addTypes:[NSArray arrayWithObject:NSStringPboardType] - owner:NSApp]; + changeCount = [pb declareTypes:[NSArray arrayWithObject:NSStringPboardType] + owner:nil]; + [NSApp tkProvidePasteboard: TkGetDisplayList() + pasteboard: (NSPasteboard *) pb + provideDataForType: (NSString *) NSStringPboardType]; + break; + case CLIPBOARD_CLEAR: + changeCount = [pb declareTypes:[NSArray arrayWithObject:NSStringPboardType] + owner:nil]; + [NSApp tkProvidePasteboard: TkGetDisplayList() + pasteboard: (NSPasteboard *) pb + provideDataForType: (NSString *) NSStringPboardType]; + break; + default: + break; + } } /* @@ -264,7 +301,7 @@ TkSelEventProc( * SelectionRequest, or SelectionNotify. */ { if (eventPtr->type == SelectionClear) { - clipboardOwner = NULL; + tkClipboardOwner = NULL; TkSelClearSelection(tkwin, eventPtr); } } diff --git a/macosx/tkMacOSXColor.c b/macosx/tkMacOSXColor.c index 6263356..f0a3265 100644 --- a/macosx/tkMacOSXColor.c +++ b/macosx/tkMacOSXColor.c @@ -600,7 +600,7 @@ TkMacOSXSetColorInContext( TkColor * TkpGetColor( Tk_Window tkwin, /* Window in which color will be used. */ - Tk_Uid name) /* Name of color to be allocated (in form + const char *name) /* Name of color to be allocated (in form * suitable for passing to XParseColor). */ { Display *display = NULL; diff --git a/macosx/tkMacOSXCursor.c b/macosx/tkMacOSXCursor.c index eb3edbc..7d0708b 100644 --- a/macosx/tkMacOSXCursor.c +++ b/macosx/tkMacOSXCursor.c @@ -393,7 +393,7 @@ TkGetCursorByName( macCursorPtr->type != NONE)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad cursor spec \"%s\"", string)); - Tcl_SetErrorCode(interp, "TK", "VALUE", "CURSOR", NULL); + Tcl_SetErrorCode(interp, "TK", "VALUE", "CURSOR", (char *)NULL); if (macCursorPtr) { ckfree(macCursorPtr); macCursorPtr = NULL; diff --git a/macosx/tkMacOSXDialog.c b/macosx/tkMacOSXDialog.c index f3923f1..a6230be 100644 --- a/macosx/tkMacOSXDialog.c +++ b/macosx/tkMacOSXDialog.c @@ -492,7 +492,7 @@ Tk_ChooseColorObjCmd( if (i + 1 == objc) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "value for \"%s\" missing", Tcl_GetString(objv[i]))); - Tcl_SetErrorCode(interp, "TK", "COLORDIALOG", "VALUE", NULL); + Tcl_SetErrorCode(interp, "TK", "COLORDIALOG", "VALUE", (char *)NULL); goto end; } value = Tcl_GetString(objv[i + 1]); @@ -750,7 +750,7 @@ Tk_GetOpenFileObjCmd( if (i + 1 == objc) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "value for \"%s\" missing", Tcl_GetString(objv[i]))); - Tcl_SetErrorCode(interp, "TK", "FILEDIALOG", "VALUE", NULL); + Tcl_SetErrorCode(interp, "TK", "FILEDIALOG", "VALUE", (char *)NULL); goto end; } switch (index) { @@ -1036,7 +1036,7 @@ Tk_GetSaveFileObjCmd( if (i + 1 == objc) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "value for \"%s\" missing", Tcl_GetString(objv[i]))); - Tcl_SetErrorCode(interp, "TK", "FILEDIALOG", "VALUE", NULL); + Tcl_SetErrorCode(interp, "TK", "FILEDIALOG", "VALUE", (char *)NULL); goto end; } switch (index) { @@ -1278,7 +1278,7 @@ Tk_ChooseDirectoryObjCmd( if (i + 1 == objc) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "value for \"%s\" missing", Tcl_GetString(objv[i]))); - Tcl_SetErrorCode(interp, "TK", "DIRDIALOG", "VALUE", NULL); + Tcl_SetErrorCode(interp, "TK", "DIRDIALOG", "VALUE", (char *)NULL); goto end; } switch (index) { @@ -1462,7 +1462,7 @@ Tk_MessageBoxObjCmd( if (i + 1 == objc) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "value for \"%s\" missing", Tcl_GetString(objv[i]))); - Tcl_SetErrorCode(interp, "TK", "MSGBOX", "VALUE", NULL); + Tcl_SetErrorCode(interp, "TK", "MSGBOX", "VALUE", (char *)NULL); goto end; } switch (index) { @@ -1547,7 +1547,7 @@ Tk_MessageBoxObjCmd( if (!defaultNativeButtonIndex) { Tcl_SetObjResult(interp, Tcl_NewStringObj("Illegal default option", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "MSGBOX", "DEFAULT", NULL); + Tcl_SetErrorCode(interp, "TK", "MSGBOX", "DEFAULT", (char *)NULL); goto end; } } @@ -1910,7 +1910,7 @@ FontchooserConfigureCmd( if (i + 1 == objc) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "value for \"%s\" missing", Tcl_GetString(objv[i]))); - Tcl_SetErrorCode(interp, "TK", "FONTDIALOG", "VALUE", NULL); + Tcl_SetErrorCode(interp, "TK", "FONTDIALOG", "VALUE", (char *)NULL); return TCL_ERROR; } switch (optionIndex) { @@ -1919,7 +1919,7 @@ FontchooserConfigureCmd( "\"-visible\": use the show or hide command"; Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "FONTDIALOG", "READONLY", NULL); + Tcl_SetErrorCode(interp, "TK", "FONTDIALOG", "READONLY", (char *)NULL); return TCL_ERROR; } case FontchooserParent: { diff --git a/macosx/tkMacOSXEmbed.c b/macosx/tkMacOSXEmbed.c index 8b556ba..f0e178c 100644 --- a/macosx/tkMacOSXEmbed.c +++ b/macosx/tkMacOSXEmbed.c @@ -214,7 +214,7 @@ Tk_UseWindow( if (winPtr->window != None) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "can't modify container after widget is created", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "EMBED", "POST_CREATE", NULL); + Tcl_SetErrorCode(interp, "TK", "EMBED", "POST_CREATE", (char *)NULL); return TCL_ERROR; } @@ -236,14 +236,14 @@ Tk_UseWindow( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't create child of window \"%s\"", string)); - Tcl_SetErrorCode(interp, "TK", "EMBED", "NO_TARGET", NULL); + Tcl_SetErrorCode(interp, "TK", "EMBED", "NO_TARGET", (char *)NULL); } return TCL_ERROR; } else if (!(usePtr->flags & TK_CONTAINER)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "window \"%s\" doesn't have -container option set", usePtr->pathName)); - Tcl_SetErrorCode(interp, "TK", "EMBED", "CONTAINER", NULL); + Tcl_SetErrorCode(interp, "TK", "EMBED", "CONTAINER", (char *)NULL); return TCL_ERROR; } diff --git a/macosx/tkMacOSXFont.c b/macosx/tkMacOSXFont.c index de2b94d..4fb3875 100644 --- a/macosx/tkMacOSXFont.c +++ b/macosx/tkMacOSXFont.c @@ -463,7 +463,7 @@ startOfClusterObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad index \"%s\": must be integer?[+-]integer?, end?[+-]integer?, or \"\"", Tcl_GetString(objv[2]))); - Tcl_SetErrorCode(interp, "TK", "VALUE", "INDEX", NULL); + Tcl_SetErrorCode(interp, "TK", "VALUE", "INDEX", (char *)NULL); return TCL_ERROR; } if (idx >= ulen) { @@ -522,7 +522,7 @@ endOfClusterObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad index \"%s\": must be integer?[+-]integer?, end?[+-]integer?, or \"\"", Tcl_GetString(objv[2]))); - Tcl_SetErrorCode(interp, "TK", "VALUE", "INDEX", NULL); + Tcl_SetErrorCode(interp, "TK", "VALUE", "INDEX", (char *)NULL); return TCL_ERROR; } if (idx >= ulen) { diff --git a/macosx/tkMacOSXImage.c b/macosx/tkMacOSXImage.c index aa16f27..05aef64 100644 --- a/macosx/tkMacOSXImage.c +++ b/macosx/tkMacOSXImage.c @@ -689,7 +689,7 @@ CreateCGImageFromDrawableRect( //CGImageGetBytesPerRow(cg_image), // wastes space? CGImageGetBitsPerPixel(cg_image) * width / 8, colorspace, - CGImageGetAlphaInfo(cg_image)); + CGImageGetBitmapInfo(cg_image)); CGColorSpaceRelease(colorspace); if (cg_context) { // Extract the subimage in the specified rectangle. @@ -1472,7 +1472,7 @@ TkMacOSXNSImageConfigureModel( if (modelPtr->sourceObj == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("-source is required.", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "SYSTEM", "BAD_VALUE", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "SYSTEM", "BAD_VALUE", (char *)NULL); goto errorExit; } @@ -1483,7 +1483,7 @@ TkMacOSXNSImageConfigureModel( Tcl_SetObjResult(interp, Tcl_NewStringObj( "Unknown interpretation for source in -as option. " "Should be name, file, path, or filetype.", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "SYSTEM", "BAD_VALUE", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "SYSTEM", "BAD_VALUE", (char *)NULL); goto errorExit; } @@ -1544,18 +1544,18 @@ TkMacOSXNSImageConfigureModel( Tcl_SetObjResult(interp, Tcl_NewStringObj("Unknown named NSImage.\n" "Try omitting ImageName, " "e.g. use NSCaution for NSImageNameCaution.", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "SYSTEM", "BAD_VALUE", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "SYSTEM", "BAD_VALUE", (char *)NULL); goto errorExit; case FILE_SOURCE: Tcl_SetObjResult(interp, Tcl_NewStringObj( "Failed to load image file.\n", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "SYSTEM", "BAD_VALUE", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "SYSTEM", "BAD_VALUE", (char *)NULL); goto errorExit; default: Tcl_SetObjResult(interp, Tcl_NewStringObj( "Unrecognized file type.\n" "If using a filename extension, do not include the dot.\n", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "IMAGE", "SYSTEM", "BAD_VALUE", NULL); + Tcl_SetErrorCode(interp, "TK", "IMAGE", "SYSTEM", "BAD_VALUE", (char *)NULL); goto errorExit; } } diff --git a/macosx/tkMacOSXInit.c b/macosx/tkMacOSXInit.c index 00c04f1..c472fbb 100644 --- a/macosx/tkMacOSXInit.c +++ b/macosx/tkMacOSXInit.c @@ -42,6 +42,8 @@ static char scriptPath[PATH_MAX + 1] = ""; static Tcl_ObjCmdProc2 TkMacOSXGetAppPathObjCmd; static Tcl_ObjCmdProc2 TkMacOSVersionObjCmd; +static Tcl_ObjCmdProc2 TkMacOSXGetInfoAsJSONObjCmd; + #pragma mark TKApplication(TKInit) @@ -270,7 +272,10 @@ static Tcl_ObjCmdProc2 TkMacOSVersionObjCmd; struct utsname name; char *endptr; if (uname(&name) == 0) { - majorVersion = (int)strtol(name.release, &endptr, 10) - 9; + majorVersion = (int)strtol(name.release, &endptr, 10) + 1; + if (majorVersion < 26) { + majorVersion -= 10; + } minorVersion = 0; } } @@ -701,6 +706,8 @@ TkpInit( TkMacOSXIconBitmapObjCmd, NULL, NULL); Tcl_CreateObjCommand2(interp, "::tk::mac::GetAppPath", TkMacOSXGetAppPathObjCmd, NULL, NULL); + Tcl_CreateObjCommand2(interp, "::tk::mac::GetInfoAsJSON", + TkMacOSXGetInfoAsJSONObjCmd, NULL, NULL); Tcl_CreateObjCommand2(interp, "::tk::mac::macOSVersion", TkMacOSVersionObjCmd, NULL, NULL); MacSystrayInit(interp); @@ -727,7 +734,7 @@ TkpInit( static int TkMacOSXGetAppPathObjCmd( - TCL_UNUSED(void *), + TCL_UNUSED(void *), /* clientData */ Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[]) @@ -815,7 +822,7 @@ TkpGetAppName( static int TkMacOSVersionObjCmd( - TCL_UNUSED(void *), + TCL_UNUSED(void *), /* clientData */ Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[]) @@ -835,6 +842,58 @@ TkMacOSVersionObjCmd( /* *---------------------------------------------------------------------- * + * TkMacOSXGetInfoAsJSONObjCmd -- + * + * Returns the contents of the Info.plist file in the application + * bundle as a JSON-encoded Tcl string. + * + * Results: + * Returns the JSON encoding of the Info.plist file.. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TkMacOSXGetInfoAsJSONObjCmd( + TCL_UNUSED(void *), /* clientData */ + Tcl_Interp *interp, + Tcl_Size objc, + Tcl_Obj *const objv[]) +{ + static char *bytes = NULL; + + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return TCL_ERROR; + } + + if (bytes == NULL) { + NSJSONWritingOptions opt = NSJSONWritingPrettyPrinted; + NSDictionary<NSString *, id> *infoDict = [[NSBundle mainBundle] + infoDictionary]; + NSData *infoAsJSON = [NSJSONSerialization + dataWithJSONObject: infoDict + options:opt + error:nil]; + if (infoAsJSON.length) { + int buffer_size = (int) infoAsJSON.length + 1; + bytes = malloc(buffer_size); + strlcpy(bytes, infoAsJSON.bytes, buffer_size); + } + } + if (bytes) { + Tcl_SetObjResult(interp, Tcl_NewStringObj(bytes, TCL_INDEX_NONE)); + return TCL_OK; + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * * TkpDisplayWarning -- * * This routines is called from Tk_Main to display warning messages that diff --git a/macosx/tkMacOSXInt.h b/macosx/tkMacOSXInt.h index feb6a32..69e3826 100644 --- a/macosx/tkMacOSXInt.h +++ b/macosx/tkMacOSXInt.h @@ -165,7 +165,7 @@ MODULE_SCOPE Bool TkTestLogDisplay(Drawable drawable); * Include the stubbed internal platform-specific API. */ -#include "tkIntPlatDecls.h" +#include "tkIntPlatDecls.h" /* IWYU pragma: export */ #endif /* _TKMACINT */ diff --git a/macosx/tkMacOSXMouseEvent.c b/macosx/tkMacOSXMouseEvent.c index ac94e1f..2e6bb1f 100644 --- a/macosx/tkMacOSXMouseEvent.c +++ b/macosx/tkMacOSXMouseEvent.c @@ -545,7 +545,7 @@ enum { } } else { static unsigned long scrollCounter = 0; - int delta; + unsigned delta; CGFloat Delta; Bool deltaIsPrecise = [theEvent hasPreciseScrollingDeltas]; XEvent xEvent = {0}; @@ -557,8 +557,8 @@ enum { xEvent.xany.display = Tk_Display(target); xEvent.xany.window = Tk_WindowId(target); if (deltaIsPrecise) { - int deltaX = [theEvent scrollingDeltaX]; - int deltaY = [theEvent scrollingDeltaY]; + unsigned deltaX = (unsigned)(int)[theEvent scrollingDeltaX]; + unsigned deltaY = (unsigned)(int)[theEvent scrollingDeltaY]; delta = (deltaX << 16) | (deltaY & 0xffff); if (delta != 0) { xEvent.type = TouchpadScroll; diff --git a/macosx/tkMacOSXRegion.c b/macosx/tkMacOSXRegion.c index d094aaf..585f990 100644 --- a/macosx/tkMacOSXRegion.c +++ b/macosx/tkMacOSXRegion.c @@ -498,6 +498,74 @@ TkMacOSHIShapeDifferenceWithRect( return result; } +/* + *---------------------------------------------------------------------- + * + * XEqualRegion -- + * + * Although the undocumented function + * + * Boolean __attribute__((overloadable)) + * __HIShapeEqual(void const *inShape1, void const *inShape2) + * + * is probably more optimal than the approach used here, + * it is "non-external" and so not easily usable by Tk Aqua. + * + *---------------------------------------------------------------------- + */ +Bool +XEqualRegion( + Region r1, + Region r2) +{ + HIShapeRef hsa = (HIShapeRef)r1, hsb = (HIShapeRef)r2; + if (hsa == hsb) { + return True; + } + CGRect ba, bb; + HIShapeGetBounds(hsa, &ba); + HIShapeGetBounds(hsb, &bb); + if (!CGRectEqualToRect(ba, bb)) { + return False; + } + HIShapeRef hsx = HIShapeCreateXor(hsa, hsb); + Bool result = HIShapeIsEmpty(hsx); + CFRelease(hsx); + return result; +} + +int +XUnionRegion( + Region srca, + Region srcb, + Region dr_return) +{ + ChkErr(HIShapeUnion, (HIShapeRef)srca, (HIShapeRef)srcb, + (HIMutableShapeRef)dr_return); + return 1; +} + +int +XXorRegion( + Region sra, + Region srb, + Region dr_return) +{ + ChkErr(HIShapeXor, (HIShapeRef)sra, (HIShapeRef)srb, + (HIMutableShapeRef)dr_return); + return 0; +} + +Bool +XPointInRegion( + Region r, + int x, + int y) +{ + CGPoint p = CGPointMake(x, y); + return HIShapeContainsPoint((HIShapeRef)r, &p); +} + static OSStatus rectCounter( TCL_UNUSED(int), @@ -518,7 +586,7 @@ rectPrinter( TCL_UNUSED(void *)) { if (rect) { - fprintf(stderr, " %s\n", NSStringFromRect(*rect).UTF8String); + fprintf(stderr, " %s\n", NSStringFromRect(NSRectFromCGRect(*rect)).UTF8String); } return noErr; } diff --git a/macosx/tkMacOSXScale.c b/macosx/tkMacOSXScale.c deleted file mode 100644 index 1442236..0000000 --- a/macosx/tkMacOSXScale.c +++ /dev/null @@ -1,470 +0,0 @@ -/* - * tkMacOSXScale.c -- - * - * This file implements the Macintosh specific portion of the - * scale widget. - * - * Copyright © 1996 Sun Microsystems, Inc. - * Copyright © 1998-2000 Scriptics Corporation. - * Copyright © 2006-2009 Daniel A. Steffen <das@users.sourceforge.net> - * Copyright © 2008-2009 Apple Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -#include "tkMacOSXPrivate.h" -#include "tkScale.h" - -#ifdef MAC_OSX_TK_TODO -/* -#ifdef TK_MAC_DEBUG -#define TK_MAC_DEBUG_SCALE -#endif -*/ - -/* - * Defines used in this file. - */ - -#define slider 1110 -#define inSlider 1 -#define inInc 2 -#define inDecr 3 - -/* - * Declaration of Macintosh specific scale structure. - */ - -typedef struct MacScale { - TkScale info; /* Generic scale info. */ - int flags; /* Flags. */ - ControlRef scaleHandle; /* Handle to the Scale control struct. */ -} MacScale; - -/* - * Globals uses locally in this file. - */ -static ControlActionUPP scaleActionProc = NULL; /* Pointer to func. */ - -/* - * Forward declarations for procedures defined later in this file: - */ - -static void MacScaleEventProc(void *clientData, - XEvent *eventPtr); -static pascal void ScaleActionProc(ControlRef theControl, - ControlPartCode partCode); - -/* - *---------------------------------------------------------------------- - * - * TkpCreateScale -- - * - * Allocate a new TkScale structure. - * - * Results: - * Returns a newly allocated TkScale structure. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -TkScale * -TkpCreateScale( - Tk_Window tkwin) -{ - MacScale *macScalePtr = (MacScale *)ckalloc(sizeof(MacScale)); - - macScalePtr->scaleHandle = NULL; - if (scaleActionProc == NULL) { - scaleActionProc = NewControlActionUPP(ScaleActionProc); - } - - Tk_CreateEventHandler(tkwin, ButtonPressMask, - MacScaleEventProc, macScalePtr); - - return (TkScale *) macScalePtr; -} - -/* - *---------------------------------------------------------------------- - * - * TkpDestroyScale -- - * - * Free Macintosh specific resources. - * - * Results: - * None - * - * Side effects: - * The slider control is destroyed. - * - *---------------------------------------------------------------------- - */ - -void -TkpDestroyScale( - TkScale *scalePtr) -{ - MacScale *macScalePtr = (MacScale *) scalePtr; - - /* - * Free Macintosh control. - */ - - if (macScalePtr->scaleHandle != NULL) { - DisposeControl(macScalePtr->scaleHandle); - } -} - -/* - *---------------------------------------------------------------------- - * - * TkpDisplayScale -- - * - * This procedure is invoked as an idle handler to redisplay the contents - * of a scale widget. - * - * Results: - * None. - * - * Side effects: - * The scale gets redisplayed. - * - *---------------------------------------------------------------------- - */ - -void -TkpDisplayScale( - void *clientData) /* Widget record for scale. */ -{ - TkScale *scalePtr = clientData; - Tk_Window tkwin = scalePtr->tkwin; - Tcl_Interp *interp = scalePtr->interp; - int result; - char string[TCL_DOUBLE_SPACE]; - MacScale *macScalePtr = clientData; - Rect r; - WindowRef windowRef; - MacDrawable *macDraw; - SInt32 initialValue, minValue, maxValue; - UInt16 numTicks; - Tcl_DString buf; - -#ifdef TK_MAC_DEBUG_SCALE - TkMacOSXDbgMsg("TkpDisplayScale"); -#endif - scalePtr->flags &= ~REDRAW_PENDING; - if ((scalePtr->tkwin == NULL) || !Tk_IsMapped(scalePtr->tkwin)) { - goto done; - } - - /* - * Invoke the scale's command if needed. - */ - - Tcl_Preserve(scalePtr); - if ((scalePtr->flags & INVOKE_COMMAND) && (scalePtr->commandObj != NULL)) { - Tcl_Preserve(interp); - if (snprintf(string, TCL_DOUBLE_SPACE, scalePtr->format, - scalePtr->value) < 0) { - string[TCL_DOUBLE_SPACE - 1] = '\0'; - } - Tcl_DStringInit(&buf); - Tcl_DStringAppend(&buf, Tcl_GetString(scalePtr->commandObj), TCL_INDEX_NONE); - Tcl_DStringAppend(&buf, " ", TCL_INDEX_NONE); - Tcl_DStringAppend(&buf, string, TCL_INDEX_NONE); - result = Tcl_EvalEx(interp, Tcl_DStringValue(&buf), TCL_INDEX_NONE, TCL_EVAL_GLOBAL); - Tcl_DStringFree(&buf); - if (result != TCL_OK) { - Tcl_AddErrorInfo(interp, "\n (command executed by scale)"); - Tcl_BackgroundException(interp, result); - } - Tcl_Release(interp); - } - scalePtr->flags &= ~INVOKE_COMMAND; - if (scalePtr->flags & SCALE_DELETED) { - Tcl_Release(scalePtr); - return; - } - Tcl_Release(scalePtr); - - /* - * Now handle the part of redisplay that is the same for horizontal and - * vertical scales: border and traversal highlight. - */ - - if (scalePtr->highlightWidth > 0) { - GC gc = Tk_GCForColor(scalePtr->highlightColorPtr, Tk_WindowId(tkwin)); - - Tk_DrawFocusHighlight(tkwin, gc, scalePtr->highlightWidth, - Tk_WindowId(tkwin)); - } - Tk_Draw3DRectangle(tkwin, Tk_WindowId(tkwin), scalePtr->bgBorder, - scalePtr->highlightWidth, scalePtr->highlightWidth, - Tk_Width(tkwin) - 2*scalePtr->highlightWidth, - Tk_Height(tkwin) - 2*scalePtr->highlightWidth, - scalePtr->borderWidth, scalePtr->relief); - - /* - * Set up port for drawing Macintosh control. - */ - - macDraw = (MacDrawable *)Tk_WindowId(tkwin); - windowRef = TkMacOSXGetNSWindowForDrawable(Tk_WindowId(tkwin)); - - /* - * Create Macintosh control. - */ - -#define MAC_OSX_SCROLL_WIDTH 10 - - if (scalePtr->orient == ORIENT_HORIZONTAL) { - int offset = (Tk_Height(tkwin) - MAC_OSX_SCROLL_WIDTH) / 2; - - if (offset < 0) { - offset = 0; - } - - r.left = macDraw->xOff + scalePtr->inset; - r.top = macDraw->yOff + offset; - r.right = macDraw->xOff+Tk_Width(tkwin) - scalePtr->inset; - r.bottom = macDraw->yOff + offset + MAC_OSX_SCROLL_WIDTH/2; - } else { - int offset = (Tk_Width(tkwin) - MAC_OSX_SCROLL_WIDTH) / 2; - - if (offset < 0) { - offset = 0; - } - - r.left = macDraw->xOff + offset; - r.top = macDraw->yOff + scalePtr->inset; - r.right = macDraw->xOff + offset + MAC_OSX_SCROLL_WIDTH/2; - r.bottom = macDraw->yOff + Tk_Height(tkwin) - scalePtr->inset; - } - - if (macScalePtr->scaleHandle == NULL) { -#ifdef TK_MAC_DEBUG_SCALE - TkMacOSXDbgMsg("Initialising scale"); -#endif - initialValue = scalePtr->value; - if (scalePtr->orient == ORIENT_HORIZONTAL) { - minValue = scalePtr->fromValue; - maxValue = scalePtr->toValue; - } else { - minValue = scalePtr->fromValue; - maxValue = scalePtr->toValue; - } - - if (scalePtr->tickInterval == 0) { - numTicks = 0; - } else { - numTicks = (maxValue - minValue)/scalePtr->tickInterval; - } - - CreateSliderControl(windowRef, &r, initialValue, minValue, maxValue, - kControlSliderPointsDownOrRight, numTicks, 1, scaleActionProc, - &macScalePtr->scaleHandle); - SetControlReference(macScalePtr->scaleHandle, (UInt32) scalePtr); - - if (IsWindowActive(windowRef)) { - macScalePtr->flags |= ACTIVE; - } - } else { - SetControlBounds(macScalePtr->scaleHandle, &r); - SetControl32BitValue(macScalePtr->scaleHandle, scalePtr->value); - SetControl32BitMinimum(macScalePtr->scaleHandle, scalePtr->fromValue); - SetControl32BitMaximum(macScalePtr->scaleHandle, scalePtr->toValue); - } - - /* - * Finally draw the control. - */ - - SetControlVisibility(macScalePtr->scaleHandle, true, true); - HiliteControl(macScalePtr->scaleHandle, 0); - Draw1Control(macScalePtr->scaleHandle); - -done: - scalePtr->flags &= ~REDRAW_ALL; -} - -/* - *---------------------------------------------------------------------- - * - * TkpScaleElement -- - * - * Determine which part of a scale widget lies under a given point. - * - * Results: - * The return value is either TROUGH1, SLIDER, TROUGH2, or OTHER, - * depending on which of the scale's active elements (if any) is under the - * point at (x,y). - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TkpScaleElement( - TkScale *scalePtr, /* Widget record for scale. */ - int x, int y) /* Coordinates within scalePtr's window. */ -{ - MacScale *macScalePtr = (MacScale *) scalePtr; - ControlPartCode part; - Point where; - Rect bounds; - -#ifdef TK_MAC_DEBUG_SCALE - TkMacOSXDbgMsg("TkpScaleElement"); -#endif - - /* - * All of the calculations in this procedure mirror those in - * DisplayScrollbar. Be sure to keep the two consistent. - */ - - TkMacOSXWinBounds((TkWindow *) scalePtr->tkwin, &bounds); - where.h = x + bounds.left; - where.v = y + bounds.top; - part = TestControl(macScalePtr->scaleHandle, where); - -#ifdef TK_MAC_DEBUG_SCALE - fprintf (stderr,"ScalePart %d, pos ( %d %d )\n", part, where.h, where.v ); -#endif - - switch (part) { - case inSlider: - return SLIDER; - case inInc: - if (scalePtr->orient == ORIENT_VERTICAL) { - return TROUGH1; - } else { - return TROUGH2; - } - case inDecr: - if (scalePtr->orient == ORIENT_VERTICAL) { - return TROUGH2; - } else { - return TROUGH1; - } - default: - return OTHER; - } -} - -/* - *-------------------------------------------------------------- - * - * MacScaleEventProc -- - * - * This procedure is invoked by the Tk dispatcher for ButtonPress events - * on scales. - * - * Results: - * None. - * - * Side effects: - * When the window gets deleted, internal structures get cleaned up. When - * it gets exposed, it is redisplayed. - * - *-------------------------------------------------------------- - */ - -static void -MacScaleEventProc( - void *clientData, /* Information about window. */ - XEvent *eventPtr) /* Information about event. */ -{ - MacScale *macScalePtr = (MacScale *) clientData; - Point where; - Rect bounds; - int part; - -#ifdef TK_MAC_DEBUG_SCALE - fprintf(stderr,"MacScaleEventProc\n" ); -#endif - - /* - * To call Macintosh control routines we must have the port set to the - * window containing the control. We will then test which part of the - * control was hit and act accordingly. - */ - - TkMacOSXDbgMsg("calling TestControl"); -#endif - part = TestControl(macScalePtr->scaleHandle, where); - if (part == 0) { - return; - } - - TkMacOSXTrackingLoop(1); - part = HandleControlClick(macScalePtr->scaleHandle, where, - TkMacOSXModifierState(), scaleActionProc); - TkMacOSXTrackingLoop(0); - - /* - * Update the value for the widget. - */ - - macScalePtr->info.value = GetControlValue(macScalePtr->scaleHandle); - /* TkScaleSetValue(&macScalePtr->info, macScalePtr->info.value, 1, 0); */ - - /* - * The HandleControlClick call will "eat" the ButtonUp event. We now - * generate a ButtonUp event so Tk will unset implicit grabs etc. - */ - - TkGenerateButtonEventForXPointer(Tk_WindowId(macScalePtr->info.tkwin)); -} - -/* - *-------------------------------------------------------------- - * - * ScaleActionProc -- - * - * Callback procedure used by the Macintosh toolbox call - * HandleControlClick. This call will update the display while the - * scrollbar is being manipulated by the user. - * - * Results: - * None. - * - * Side effects: - * May change the display. - * - *-------------------------------------------------------------- - */ - -static pascal void -ScaleActionProc( - ControlRef theControl, /* Handle to scrollbat control */ - ControlPartCode partCode) /* Part of scrollbar that was "hit" */ -{ - int value; - TkScale *scalePtr = (TkScale *) GetControlReference(theControl); - -#ifdef TK_MAC_DEBUG_SCALE - TkMacOSXDbgMsg("ScaleActionProc"); -#endif - value = GetControlValue(theControl); - TkScaleSetValue(scalePtr, value, 1, 1); - Tcl_Preserve(scalePtr); - TkMacOSXRunTclEventLoop(); - Tcl_Release(scalePtr); -} -#endif - -/* - * Local Variables: - * mode: objc - * c-basic-offset: 4 - * fill-column: 79 - * coding: utf-8 - * End: - */ diff --git a/macosx/tkMacOSXTest.c b/macosx/tkMacOSXTest.c index 59ddb15..2650e55 100644 --- a/macosx/tkMacOSXTest.c +++ b/macosx/tkMacOSXTest.c @@ -342,7 +342,7 @@ TestinjectkeyeventObjCmd( if (Tcl_GetIntFromObj(interp, objv[2], &keysym) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "keysym must be an integer")); - Tcl_SetErrorCode(interp, "TK", "TEST", "INJECT", "KEYSYM", NULL); + Tcl_SetErrorCode(interp, "TK", "TEST", "INJECT", "KEYSYM", (char *)NULL); return TCL_ERROR; } macKC.uint = XKeysymToKeycode(NULL, keysym); diff --git a/macosx/tkMacOSXWindowEvent.c b/macosx/tkMacOSXWindowEvent.c index 1663e00..7674e66 100644 --- a/macosx/tkMacOSXWindowEvent.c +++ b/macosx/tkMacOSXWindowEvent.c @@ -1260,6 +1260,17 @@ static const char *const accentNames[] = { Tk_SendVirtualEvent(tkwin, "AppearanceChanged", Tcl_NewStringObj(data, TCL_INDEX_NONE)); // Force a redraw of the view. [self setFrameSize:self.frame.size]; + + /* + * Create the *Tglswitch*.trough and *Tglswitch*.slider + * elements for the Toggleswitch* styles if necessary + */ + Tcl_Interp *interp = Tk_Interp(tkwin); + int code = Tcl_EvalEx(interp, "ttk::toggleswitch::CondUpdateElements", + TCL_INDEX_NONE, TCL_EVAL_GLOBAL); + if (code != TCL_OK) { + Tcl_BackgroundException(interp, code); + } } - (void)observeValueForKeyPath:(NSString *)keyPath diff --git a/macosx/tkMacOSXWm.c b/macosx/tkMacOSXWm.c index 23bcead..cb19de3 100644 --- a/macosx/tkMacOSXWm.c +++ b/macosx/tkMacOSXWm.c @@ -1468,7 +1468,7 @@ Tk_WmObjCmd( if (winPtr->wmInfoPtr->window != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "Cannot change the class after the mac window is created.",-1)); - Tcl_SetErrorCode(interp, "TK", "CLASS_CHANGE", NULL); + Tcl_SetErrorCode(interp, "TK", "CLASS_CHANGE", (char *)NULL); return TCL_ERROR; } } else { @@ -1630,7 +1630,7 @@ WmAspectCmd( (denom2 <= 0)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "aspect number can't be <= 0", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "WM", "ASPECT", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "ASPECT", (char *)NULL); return TCL_ERROR; } wmPtr->minAspect.x = numer1; @@ -1792,7 +1792,7 @@ WmSetAttribute( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "styleMask bit \"%s\" can only be used with an NSPanel", styleMaskBits[index].bitname)); - Tcl_SetErrorCode(interp, "TK", "INVALID_STYLEMASK_BIT", NULL); + Tcl_SetErrorCode(interp, "TK", "INVALID_STYLEMASK_BIT", (char *)NULL); return TCL_ERROR; } else { styleMaskValue |= styleMaskBits[index].bitvalue; @@ -1860,7 +1860,7 @@ WmSetAttribute( if ([NSApp macOSVersion] < 101300) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "Tabbing identifiers require macOS 10.13", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "WM", "TABBINGID", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "TABBINGID", (char *)NULL); return TCL_ERROR; } valueString = Tcl_GetStringFromObj(value, &length); @@ -2155,7 +2155,7 @@ WmAttributesCmd( if (!winPtr) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "Only -class, -tabbingid, or -tabbingmode can be set before the window exists.")); - Tcl_SetErrorCode(interp, "TK", "NO_WINDOW", NULL); + Tcl_SetErrorCode(interp, "TK", "NO_WINDOW", (char *)NULL); return TCL_ERROR; } if (winPtr && winPtr->window == None) { @@ -2440,13 +2440,13 @@ WmDeiconifyCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't deiconify %s: it is an icon for %s", Tcl_GetString(objv[2]), Tk_PathName(wmPtr->iconFor))); - Tcl_SetErrorCode(interp, "TK", "WM", "DEICONIFY", "ICON", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "DEICONIFY", "ICON", (char *)NULL); return TCL_ERROR; } else if (winPtr->flags & TK_EMBEDDED) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't deiconify %s: it is an embedded window", winPtr->pathName)); - Tcl_SetErrorCode(interp, "TK", "WM", "DEICONIFY", "EMBEDDED", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "DEICONIFY", "EMBEDDED", (char *)NULL); return TCL_ERROR; } @@ -2812,7 +2812,7 @@ WmGridCmd( error: Tcl_SetObjResult(interp, Tcl_NewStringObj(errorMsg, TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "WM", "GRID", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "GRID", (char *)NULL); return TCL_ERROR; } @@ -3059,19 +3059,19 @@ WmIconifyCmd( } else if (wmPtr->container != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't iconify \"%s\": it is a transient", winPtr->pathName)); - Tcl_SetErrorCode(interp, "TK", "WM", "ICONIFY", "TRANSIENT", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "ICONIFY", "TRANSIENT", (char *)NULL); return TCL_ERROR; } else if (wmPtr->iconFor != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't iconify \"%s\": it is an icon for \"%s\"", winPtr->pathName, Tk_PathName(wmPtr->iconFor))); - Tcl_SetErrorCode(interp, "TK", "WM", "ICONIFY", "ICON", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "ICONIFY", "ICON", (char *)NULL); return TCL_ERROR; } else if (winPtr->flags & TK_EMBEDDED) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't iconify \"%s\": it is an embedded window", winPtr->pathName)); - Tcl_SetErrorCode(interp, "TK", "WM", "ICONIFY", "EMBEDDED", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "ICONIFY", "EMBEDDED", (char *)NULL); return TCL_ERROR; } @@ -3280,7 +3280,7 @@ WmIconphotoCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't use \"%s\" as iconphoto: not a photo image", icon)); - Tcl_SetErrorCode(interp, "TK", "WM", "ICONPHOTO", "PHOTO", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "ICONPHOTO", "PHOTO", (char *)NULL); return TCL_ERROR; } @@ -3293,7 +3293,7 @@ WmIconphotoCmd( if (newIcon == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "failed to create an iconphoto with image \"%s\"", icon)); - Tcl_SetErrorCode(interp, "TK", "WM", "ICONPHOTO", "IMAGE", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "ICONPHOTO", "IMAGE", (char *)NULL); return TCL_ERROR; } [NSApp setApplicationIconImage: newIcon]; @@ -3424,7 +3424,7 @@ WmIconwindowCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s is already an icon for %s", Tcl_GetString(objv[3]), Tk_PathName(wmPtr2->iconFor))); - Tcl_SetErrorCode(interp, "TK", "WM", "ICONWINDOW", "ICON", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "ICONWINDOW", "ICON", (char *)NULL); return TCL_ERROR; } if (wmPtr->icon != NULL) { @@ -3502,7 +3502,7 @@ WmManageCmd( "window \"%s\" is not manageable: must be a" " frame, labelframe or toplevel", Tk_PathName(frameWin))); - Tcl_SetErrorCode(interp, "TK", "WM", "MANAGE", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "MANAGE", (char *)NULL); return TCL_ERROR; } @@ -4085,19 +4085,19 @@ WmStackorderCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "window \"%s\" isn't a top-level window", winPtr2->pathName)); - Tcl_SetErrorCode(interp, "TK", "WM", "STACK", "TOPLEVEL", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "STACK", "TOPLEVEL", (char *)NULL); return TCL_ERROR; } if (!Tk_IsMapped(winPtr)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "window \"%s\" isn't mapped", winPtr->pathName)); - Tcl_SetErrorCode(interp, "TK", "WM", "STACK", "MAPPED", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "STACK", "MAPPED", (char *)NULL); return TCL_ERROR; } else if (!Tk_IsMapped(winPtr2)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "window \"%s\" isn't mapped", winPtr2->pathName)); - Tcl_SetErrorCode(interp, "TK", "WM", "STACK", "MAPPED", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "STACK", "MAPPED", (char *)NULL); return TCL_ERROR; } @@ -4110,7 +4110,7 @@ WmStackorderCmd( if (windows == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "TkWmStackorderToplevel failed", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "WM", "STACK", "FAIL", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "STACK", "FAIL", (char *)NULL); return TCL_ERROR; } @@ -4186,14 +4186,14 @@ WmStateCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't change state of \"%s\": it is an icon for \"%s\"", Tcl_GetString(objv[2]), Tk_PathName(wmPtr->iconFor))); - Tcl_SetErrorCode(interp, "TK", "WM", "STATE", "ICON", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "STATE", "ICON", (char *)NULL); return TCL_ERROR; } if (winPtr->flags & TK_EMBEDDED) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't change state of \"%s\": it is an embedded window", winPtr->pathName)); - Tcl_SetErrorCode(interp, "TK", "WM", "STATE", "EMBEDDED", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "STATE", "EMBEDDED", (char *)NULL); return TCL_ERROR; } @@ -4375,7 +4375,7 @@ WmTransientCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't make \"%s\" a transient: it is an icon for %s", Tcl_GetString(objv[2]), Tk_PathName(wmPtr->iconFor))); - Tcl_SetErrorCode(interp, "TK", "WM", "TRANSIENT", "ICON", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "TRANSIENT", "ICON", (char *)NULL); return TCL_ERROR; } @@ -4389,7 +4389,7 @@ WmTransientCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't make \"%s\" a container: it is an icon for %s", Tcl_GetString(objv[3]), Tk_PathName(wmPtr2->iconFor))); - Tcl_SetErrorCode(interp, "TK", "WM", "TRANSIENT", "ICON", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "TRANSIENT", "ICON", (char *)NULL); return TCL_ERROR; } @@ -4399,7 +4399,7 @@ WmTransientCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't set \"%s\" as container: would cause management loop", Tk_PathName(containerPtr))); - Tcl_SetErrorCode(interp, "TK", "WM", "TRANSIENT", "SELF", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "TRANSIENT", "SELF", (char *)NULL); return TCL_ERROR; } } @@ -4529,7 +4529,7 @@ WmWithdrawCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't withdraw %s: it is an icon for %s", Tcl_GetString(objv[2]), Tk_PathName(wmPtr->iconFor))); - Tcl_SetErrorCode(interp, "TK", "WM", "WITHDRAW", "ICON", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "WITHDRAW", "ICON", (char *)NULL); return TCL_ERROR; } @@ -5205,7 +5205,7 @@ ParseGeometry( error: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad geometry specifier \"%s\"", string)); - Tcl_SetErrorCode(interp, "TK", "VALUE", "GEOMETRY", NULL); + Tcl_SetErrorCode(interp, "TK", "VALUE", "GEOMETRY", (char *)NULL); return TCL_ERROR; } @@ -6062,15 +6062,15 @@ TkMacOSXGrowToplevel( void TkSetWMName( TkWindow *winPtr, - Tk_Uid titleUid) + const char *title) { if (Tk_IsEmbedded(winPtr)) { return; } - NSString *title = [[TKNSString alloc] initWithTclUtfBytes:titleUid length:TCL_INDEX_NONE]; - [TkMacOSXGetNSWindowForDrawable(winPtr->window) setTitle:title]; - [title release]; + NSString *nstitle = [[TKNSString alloc] initWithTclUtfBytes:title length:TCL_INDEX_NONE]; + [TkMacOSXGetNSWindowForDrawable(winPtr->window) setTitle:nstitle]; + [nstitle release]; } /* @@ -6291,7 +6291,7 @@ TkUnsupported1ObjCmd( if (!(winPtr->flags & TK_TOP_LEVEL)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "window \"%s\" isn't a top-level window", winPtr->pathName)); - Tcl_SetErrorCode(interp, "TK", "WINDOWSTYLE", "TOPLEVEL", NULL); + Tcl_SetErrorCode(interp, "TK", "WINDOWSTYLE", "TOPLEVEL", (char *)NULL); return TCL_ERROR; } @@ -6315,7 +6315,7 @@ TkUnsupported1ObjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "Window appearances cannot be changed before OSX 10.14.", -1)); - Tcl_SetErrorCode(interp, "TK", "WINDOWSTYLE", "APPEARANCE", NULL); + Tcl_SetErrorCode(interp, "TK", "WINDOWSTYLE", "APPEARANCE", (char *)NULL); return TCL_ERROR; } return WmWinAppearance(interp, winPtr, objc, objv); @@ -7243,17 +7243,16 @@ XSetInputFocus( *---------------------------------------------------------------------- */ -int +size_t TkpChangeFocus( TkWindow *winPtr, /* Window that is to receive the X focus. */ int force) /* Non-zero means claim the focus even if it * didn't originally belong to topLevelPtr's * application. */ { - if (!winPtr || - (winPtr->flags & TK_ALREADY_DEAD) || - !Tk_IsMapped(winPtr) || - winPtr->atts.override_redirect) { + if (!winPtr || (winPtr->flags & TK_ALREADY_DEAD) + || !Tk_IsMapped(winPtr) || + winPtr->atts.override_redirect) { return 0; } if (Tk_IsTopLevel(winPtr) && !Tk_IsEmbedded(winPtr)) { diff --git a/macosx/ttkMacOSXTheme.c b/macosx/ttkMacOSXTheme.c index 44259e0..df32035 100644 --- a/macosx/ttkMacOSXTheme.c +++ b/macosx/ttkMacOSXTheme.c @@ -3568,67 +3568,67 @@ static int AquaTheme_Init( * Elements: */ - Ttk_RegisterElementSpec(themePtr, "background", &BackgroundElementSpec, + Ttk_RegisterElement(NULL, themePtr, "background", &BackgroundElementSpec, 0); - Ttk_RegisterElementSpec(themePtr, "fill", &FillElementSpec, 0); - Ttk_RegisterElementSpec(themePtr, "field", &FieldElementSpec, 0); - Ttk_RegisterElementSpec(themePtr, "Toolbar.background", + Ttk_RegisterElement(NULL, themePtr, "fill", &FillElementSpec, 0); + Ttk_RegisterElement(NULL, themePtr, "field", &FieldElementSpec, 0); + Ttk_RegisterElement(NULL, themePtr, "Toolbar.background", &ToolbarBackgroundElementSpec, 0); - Ttk_RegisterElementSpec(themePtr, "Button.button", + Ttk_RegisterElement(NULL, themePtr, "Button.button", &ButtonElementSpec, &PushButtonParams); - Ttk_RegisterElementSpec(themePtr, "InlineButton.button", + Ttk_RegisterElement(NULL, themePtr, "InlineButton.button", &ButtonElementSpec, &InlineButtonParams); - Ttk_RegisterElementSpec(themePtr, "RoundedRectButton.button", + Ttk_RegisterElement(NULL, themePtr, "RoundedRectButton.button", &ButtonElementSpec, &RoundedRectButtonParams); - Ttk_RegisterElementSpec(themePtr, "Checkbutton.button", + Ttk_RegisterElement(NULL, themePtr, "Checkbutton.button", &ButtonElementSpec, &CheckBoxParams); - Ttk_RegisterElementSpec(themePtr, "Radiobutton.button", + Ttk_RegisterElement(NULL, themePtr, "Radiobutton.button", &ButtonElementSpec, &RadioButtonParams); - Ttk_RegisterElementSpec(themePtr, "RecessedButton.button", + Ttk_RegisterElement(NULL, themePtr, "RecessedButton.button", &ButtonElementSpec, &RecessedButtonParams); - Ttk_RegisterElementSpec(themePtr, "SidebarButton.button", + Ttk_RegisterElement(NULL, themePtr, "SidebarButton.button", &ButtonElementSpec, &SidebarButtonParams); - Ttk_RegisterElementSpec(themePtr, "Toolbutton.border", + Ttk_RegisterElement(NULL, themePtr, "Toolbutton.border", &ButtonElementSpec, &BevelButtonParams); - Ttk_RegisterElementSpec(themePtr, "Menubutton.button", + Ttk_RegisterElement(NULL, themePtr, "Menubutton.button", &ButtonElementSpec, &PopupButtonParams); - Ttk_RegisterElementSpec(themePtr, "DisclosureButton.button", + Ttk_RegisterElement(NULL, themePtr, "DisclosureButton.button", &ButtonElementSpec, &DisclosureButtonParams); - Ttk_RegisterElementSpec(themePtr, "HelpButton.button", + Ttk_RegisterElement(NULL, themePtr, "HelpButton.button", &ButtonElementSpec, &HelpButtonParams); - Ttk_RegisterElementSpec(themePtr, "GradientButton.button", + Ttk_RegisterElement(NULL, themePtr, "GradientButton.button", &ButtonElementSpec, &GradientButtonParams); - Ttk_RegisterElementSpec(themePtr, "Spinbox.uparrow", + Ttk_RegisterElement(NULL, themePtr, "Spinbox.uparrow", &SpinButtonUpElementSpec, 0); - Ttk_RegisterElementSpec(themePtr, "Spinbox.downarrow", + Ttk_RegisterElement(NULL, themePtr, "Spinbox.downarrow", &SpinButtonDownElementSpec, 0); - Ttk_RegisterElementSpec(themePtr, "Combobox.button", + Ttk_RegisterElement(NULL, themePtr, "Combobox.button", &ComboboxElementSpec, 0); - Ttk_RegisterElementSpec(themePtr, "Treeitem.indicator", + Ttk_RegisterElement(NULL, themePtr, "Treeitem.indicator", &DisclosureElementSpec, &DisclosureParams); - Ttk_RegisterElementSpec(themePtr, "Treeheading.cell", + Ttk_RegisterElement(NULL, themePtr, "Treeheading.cell", &TreeHeaderElementSpec, &ListHeaderParams); - Ttk_RegisterElementSpec(themePtr, "Treeview.treearea", + Ttk_RegisterElement(NULL, themePtr, "Treeview.treearea", &TreeAreaElementSpec, 0); - Ttk_RegisterElementSpec(themePtr, "Notebook.tab", &TabElementSpec, 0); - Ttk_RegisterElementSpec(themePtr, "Notebook.client", &PaneElementSpec, 0); + Ttk_RegisterElement(NULL, themePtr, "Notebook.tab", &TabElementSpec, 0); + Ttk_RegisterElement(NULL, themePtr, "Notebook.client", &PaneElementSpec, 0); - Ttk_RegisterElementSpec(themePtr, "Labelframe.border", &GroupElementSpec, + Ttk_RegisterElement(NULL, themePtr, "Labelframe.border", &GroupElementSpec, 0); - Ttk_RegisterElementSpec(themePtr, "Entry.field", &EntryElementSpec, + Ttk_RegisterElement(NULL, themePtr, "Entry.field", &EntryElementSpec, &EntryFieldParams); - Ttk_RegisterElementSpec(themePtr, "Searchbox.field", &EntryElementSpec, + Ttk_RegisterElement(NULL, themePtr, "Searchbox.field", &EntryElementSpec, &SearchboxFieldParams); - Ttk_RegisterElementSpec(themePtr, "Spinbox.field", &EntryElementSpec, + Ttk_RegisterElement(NULL, themePtr, "Spinbox.field", &EntryElementSpec, &EntryFieldParams); - Ttk_RegisterElementSpec(themePtr, "separator", &SeparatorElementSpec, 0); - Ttk_RegisterElementSpec(themePtr, "hseparator", &SeparatorElementSpec, 0); - Ttk_RegisterElementSpec(themePtr, "vseparator", &SeparatorElementSpec, 0); + Ttk_RegisterElement(NULL, themePtr, "separator", &SeparatorElementSpec, 0); + Ttk_RegisterElement(NULL, themePtr, "hseparator", &SeparatorElementSpec, 0); + Ttk_RegisterElement(NULL, themePtr, "vseparator", &SeparatorElementSpec, 0); - Ttk_RegisterElementSpec(themePtr, "sizegrip", &SizegripElementSpec, 0); + Ttk_RegisterElement(NULL, themePtr, "sizegrip", &SizegripElementSpec, 0); /* * <<NOTE-TRACKS>> @@ -3637,20 +3637,20 @@ static int AquaTheme_Init( * of the progress bar, so we just have a single element called ".track". */ - Ttk_RegisterElementSpec(themePtr, "Progressbar.track", &PbarElementSpec, + Ttk_RegisterElement(NULL, themePtr, "Progressbar.track", &PbarElementSpec, 0); - Ttk_RegisterElementSpec(themePtr, "Scale.trough", &TrackElementSpec, + Ttk_RegisterElement(NULL, themePtr, "Scale.trough", &TrackElementSpec, &ScaleData); - Ttk_RegisterElementSpec(themePtr, "Scale.slider", &SliderElementSpec, 0); + Ttk_RegisterElement(NULL, themePtr, "Scale.slider", &SliderElementSpec, 0); - Ttk_RegisterElementSpec(themePtr, "Vertical.Scrollbar.trough", + Ttk_RegisterElement(NULL, themePtr, "Vertical.Scrollbar.trough", &TroughElementSpec, 0); - Ttk_RegisterElementSpec(themePtr, "Vertical.Scrollbar.thumb", + Ttk_RegisterElement(NULL, themePtr, "Vertical.Scrollbar.thumb", &ThumbElementSpec, 0); - Ttk_RegisterElementSpec(themePtr, "Horizontal.Scrollbar.trough", + Ttk_RegisterElement(NULL, themePtr, "Horizontal.Scrollbar.trough", &TroughElementSpec, 0); - Ttk_RegisterElementSpec(themePtr, "Horizontal.Scrollbar.thumb", + Ttk_RegisterElement(NULL, themePtr, "Horizontal.Scrollbar.thumb", &ThumbElementSpec, 0); /* @@ -3658,13 +3658,13 @@ static int AquaTheme_Init( * displayed. */ - Ttk_RegisterElementSpec(themePtr, "Vertical.Scrollbar.uparrow", + Ttk_RegisterElement(NULL, themePtr, "Vertical.Scrollbar.uparrow", &ArrowElementSpec, 0); - Ttk_RegisterElementSpec(themePtr, "Vertical.Scrollbar.downarrow", + Ttk_RegisterElement(NULL, themePtr, "Vertical.Scrollbar.downarrow", &ArrowElementSpec, 0); - Ttk_RegisterElementSpec(themePtr, "Horizontal.Scrollbar.leftarrow", + Ttk_RegisterElement(NULL, themePtr, "Horizontal.Scrollbar.leftarrow", &ArrowElementSpec, 0); - Ttk_RegisterElementSpec(themePtr, "Horizontal.Scrollbar.rightarrow", + Ttk_RegisterElement(NULL, themePtr, "Horizontal.Scrollbar.rightarrow", &ArrowElementSpec, 0); /* diff --git a/tests/all.tcl b/tests/all.tcl index fcdbd23..d1f4e39 100644 --- a/tests/all.tcl +++ b/tests/all.tcl @@ -1,7 +1,7 @@ # all.tcl -- # # This file contains a top-level script to run all of the Tk -# tests. Execute it by invoking "source all.tcl" when running tktest +# tests. Execute it by invoking "source all.tcl" when running tktest # in this directory. # # Copyright © 1998-1999 Scriptics Corporation. @@ -9,13 +9,49 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# REQUIREMENTS +# package require tk ;# This is the Tk test suite; fail early if no Tk! package require tcltest 2.2 -tcltest::configure {*}$argv -tcltest::configure -testdir [file normalize [file dirname [info script]]] -tcltest::configure -loadfile \ - [file join [tcltest::testsDirectory] main.tcl] + +# +# TCLTEST CONFIGURATION +# + +# Set defaults for the Tk test suite tcltest::configure -singleproc 1 -set ErrorOnFailures [info exists env(ERROR_ON_FAILURES)] -encoding system utf-8 -if {[tcltest::runAllTests] && $ErrorOnFailures} {exit 1} + +# Handle command line parameters +if {[llength $argv] & 1} { + puts stderr "error: the number of command line parameters must be even (name - value pairs)." + exit 1 +} +set ignoredOptions [list -testdir] +set ignoredIndices [list ] +set index 0 +foreach {key value} $argv { + if {$key in $ignoredOptions} { + lappend ignoredIndices $index + puts stderr "warning: the Tk test suite ignores the option \"$key\" on the command line." + } + incr index 2 +} +set tcltestOptions $argv +foreach index [lreverse $ignoredIndices] { + set tcltestOptions [lreplace $tcltestOptions $index [expr {$index + 1}]] +} +tcltest::configure {*}$tcltestOptions +unset ignoredIndices ignoredOptions index tcltestOptions + +# Set tcltest options that are not user-configurable for the Tk test suite +tcltest::configure -testdir [file normalize [file dirname [info script]]] + +# +# RUN ALL TESTS +# + +# Note: the environment variable ERROR_ON_FAILURES is set by Github CI +if {[tcltest::runAllTests] && [info exists env(ERROR_ON_FAILURES)]} { + exit 1 +} diff --git a/tests/attribtable.test b/tests/attribtable.test new file mode 100644 index 0000000..752c116 --- /dev/null +++ b/tests/attribtable.test @@ -0,0 +1,102 @@ +# +# tk attribtable command tests +# + +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed for "-singleproc 0" + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# TESTS +# + +test tk_attribtable-1.1 "tableName set" -body { + tk attribtable table + pack [button .btn -text Button] + set prevText [.btn cget -text] + .btn configure -text "NewText" + table set .btn prevText $prevText +} -result {} + +test tk_attribtable-1.2 "tableName get" -body { + list [table get .btn prevText] [table get .btn curText] +} -result [list Button {}] + +test tk_attribtable-1.3 "tableName get - all" -body { + table get .btn +} -result [list prevText Button] + +test tk_attribtable-1.4 "tableName exists" -body { + list [table exists .btn prevText] [table exists .btn curText] +} -result [list 1 0] + +test tk_attribtable-1.5 "tableName names" -body { + table names .btn +} -result [list prevText] + +test tk_attribtable-1.6 "tableName pathnames" -body { + table pathnames +} -result [list .btn] + +test tk_attribtable-1.7 "tableName unset" -body { + table unset .btn prevText +} -result {} + +test tk_attribtable-1.8 "tableName get - after unset" -body { + table get .btn prevText "Default Text" +} -result "Default Text" + +test tk_attribtable-1.9 "tableName exists - after unset" -body { + table exists .btn prevText +} -result 0 + +test tk_attribtable-1.10 "tableName names - after unset" -body { + table names .btn +} -result [list] + +test tk_attribtable-1.1 "tableName pathnames - after unset" -body { + table pathnames +} -result [list] + + +test tk_attribtable-2.1 "tableName bad op" -body { + catch {table badOp .btn} +} -result 1 + +test tk_attribtable-2.2 "tableName bad window" -body { + catch {table get .bad.window.path.name prevText} +} -result 1 + +test tk_attribtable-2.3 "tableName set - wrong # args" -body { + list [catch {table set .btn}] [catch {table set .btn prevText}] +} -result [list 1 1] + +test tk_attribtable-2.4 "tableName get - wrong # args" -body { + catch {table get .btn oldText prevText curText} +} -result 1 + +test tk_attribtable-2.5 "tableName exists - wrong # args" -body { + list [catch {table exists .btn prevText curText}] \ + [catch {table exists .btn oldText prevText curText}] +} -cleanup { + destroy .btn +} -result [list 1 1] + +# +# TESTFILE CLEANUP +# + +tcltest::cleanupTests diff --git a/tests/bell.test b/tests/bell.test index 935ce8f..228bd63 100644 --- a/tests/bell.test +++ b/tests/bell.test @@ -1,14 +1,29 @@ # This file is a Tcl script to test out Tk's "bell" command. -# It is organized in the standard fashion for Tcl tests. # # Copyright © 1994 The Regents of the University of California. # Copyright © 1998-2000 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -eval tcltest::configure $argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# TESTS +# test bell-1.1 {bell command} -body { bell a @@ -49,5 +64,8 @@ test bell-1.8 {bell command} -body { bell } -result {} +# +# TESTFILE CLEANUP +# + cleanupTests -return diff --git a/tests/bgerror.test b/tests/bgerror.test index eda8ba6..fc3611c 100644 --- a/tests/bgerror.test +++ b/tests/bgerror.test @@ -1,14 +1,34 @@ # This file is a Tcl script to test the bgerror command. -# It is organized in the standard fashion for Tcl tests. # # Copyright © 1997 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -eval tcltest::configure $argv -tcltest::loadTestedCommands +# NOTE +# +# Some testing of the default error dialog would be needed too, but that's +# not easy at all to emulate. + +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# TESTS +# test bgerror-1.1 {bgerror / tkerror compat} -setup { set errRes {} @@ -57,11 +77,8 @@ test bgerror-1.3 {bgerror / tkerror compat / accumulation / break} -setup { catch {rename tkerror {}} } -result {err1} +# +# TESTFILE CLEANUP +# -# some testing of the default error dialog -# would be needed too, but that's not easy at all -# to emulate. - -# cleanup cleanupTests -return diff --git a/tests/bind.test b/tests/bind.test index 548a4a3..c067fc0 100644 --- a/tests/bind.test +++ b/tests/bind.test @@ -1,16 +1,32 @@ # This file is a Tcl script to test out Tk's "bind" and "bindtags" -# commands plus the procedures in tkBind.c. It is organized in the -# standard fashion for Tcl tests. +# commands plus the procedures in tkBind.c. # # Copyright © 1994 The Regents of the University of California. # Copyright © 1994-1995 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -eval tcltest::configure $argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# COMMON TEST SETUP +# + tk useinputmethods 0 toplevel .t -width 100 -height 50 @@ -25,6 +41,69 @@ foreach event [bind all] { bind all $event {} } +# move the mouse pointer away of the testing area +# otherwise some spurious events may pollute the tests +toplevel .top +wm geometry .top 50x50-50-50 +update +event generate .top <Button-1> -warp 1 +controlPointerWarpTiming +destroy .top + +# +# LOCAL UTILITY PROCS +# + +proc testKey {window event type mods} { + global keyInfo numericKeysym + set keyInfo {} + set numericKeysym {} + bind $window <Key> { + set keyInfo [format "%K,0x%%X,0x%%X,%A" %N %k] + set numericKeysym %N + } + focus -force $window + update + event generate $window $event + if {$keyInfo == {}} { + vwait keyInfo + } + set save $keyInfo + set keyInfo {} + set injectcmd [list testinjectkeyevent $type $numericKeysym] + foreach {option} $mods { + lappend injectcmd $option + } + eval $injectcmd + if {$keyInfo == {}} { + vwait keyInfo + } + if {$save != $keyInfo} { + return "[format "0x%x" $numericKeysym] ($mods): $save != $keyInfo" + } + return pass +} + +proc testKeyWithMods {window keysym type} { + set result [testKey $window "<$keysym>" $type {}] + if {$result != {pass}} { + return $result + } + set result [testKey $window "<Shift-$keysym>" $type {-shift}] + if {$result != {pass}} { + return $result + } + set result [testKey $window "<Option-$keysym>" $type {-option}] + if {$result != {pass}} { + return $result + } + set result [testKey $window "<Shift-Option-$keysym>" $type {-shift -option}] + if {$result != {pass}} { + return $result + } + return pass +} + proc unsetBindings {} { bind all <Enter> {} bind Test <Enter> {} @@ -34,14 +113,9 @@ proc unsetBindings {} { bind .t <Enter> {} } -# move the mouse pointer away of the testing area -# otherwise some spurious events may pollute the tests -toplevel .top -wm geometry .top 50x50-50-50 -update -event generate .top <Button-1> -warp 1 -controlPointerWarpTiming -destroy .top +# +# TESTS +# test bind-1.1 {bind command} -body { bind @@ -6913,56 +6987,6 @@ test bind-34.3 {-warp works with null or negative coordinates} -setup { } -cleanup { } -result {ok ok ok ok} -set keyInfo {} -set numericKeysym {} -proc testKey {window event type mods} { - global keyInfo numericKeysym - set keyInfo {} - set numericKeysym {} - bind $window <Key> { - set keyInfo [format "%K,0x%%X,0x%%X,%A" %N %k] - set numericKeysym %N - } - focus -force $window - update - event generate $window $event - if {$keyInfo == {}} { - vwait keyInfo - } - set save $keyInfo - set keyInfo {} - set injectcmd [list testinjectkeyevent $type $numericKeysym] - foreach {option} $mods { - lappend injectcmd $option - } - eval $injectcmd - if {$keyInfo == {}} { - vwait keyInfo - } - if {$save != $keyInfo} { - return "[format "0x%x" $numericKeysym] ($mods): $save != $keyInfo" - } - return pass -} -proc testKeyWithMods {window keysym type} { - set result [testKey $window "<$keysym>" $type {}] - if {$result != {pass}} { - return $result - } - set result [testKey $window "<Shift-$keysym>" $type {-shift}] - if {$result != {pass}} { - return $result - } - set result [testKey $window "<Option-$keysym>" $type {-option}] - if {$result != {pass}} { - return $result - } - set result [testKey $window "<Shift-Option-$keysym>" $type {-shift -option}] - if {$result != {pass}} { - return $result - } - return pass -} test bind-35.0 {Generated and real key events agree} -constraints {aqua} -body { foreach k {o O F2 Home Right Greek_sigma Greek_ALPHA} { set result [testKeyWithMods . $k press] @@ -7100,9 +7124,11 @@ test bind-37.1 {Promotion tables do not contain duplicate sequences, bug [435739 destroy .c } -returnCodes ok -result {} ; # shall not crash (assertion failed) -# cleanup +# +# TESTFILE CLEANUP +# + cleanupTests -return # vi:set ts=4 sw=4 et: # Local Variables: diff --git a/tests/bitmap.test b/tests/bitmap.test index 02c0f40..8457822 100644 --- a/tests/bitmap.test +++ b/tests/bitmap.test @@ -1,15 +1,30 @@ # This file is a Tcl script to test out the procedures in the file -# tkBitmap.c. It is organized in the standard white-box fashion for -# Tcl tests. +# tkBitmap.c. # # Copyright © 1998 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -eval tcltest::configure $argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# TESTS +# test bitmap-1.1 {Tk_AllocBitmapFromObj - converting internal reps} -constraints { testbitmap @@ -108,7 +123,8 @@ test bitmap-4.1 {FreeBitmapObjProc} -constraints { destroy .b } -result {{{1 3}} {{1 2}} {{1 1}} {}} +# +# TESTFILE CLEANUP +# -# cleanup cleanupTests -return diff --git a/tests/border.test b/tests/border.test index 96ebdcf..b144d90 100644 --- a/tests/border.test +++ b/tests/border.test @@ -1,14 +1,30 @@ # This file is a Tcl script to test out the procedures in the file -# tkBorder.c. It is organized in the standard fashion for Tcl tests. +# tkBorder.c. # # Copyright © 1998 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -eval tcltest::configure $argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# TESTS +# test border-1.1 {Tk_AllocBorderFromObj - converting internal reps} -constraints { testborder @@ -196,7 +212,8 @@ test border-4.7 {Tk_GetReliefFromObj - error} -body { destroy .b } -returnCodes error -result {bad relief "upanddown": must be flat, groove, raised, ridge, solid, or sunken} +# +# TESTFILE CLEANUP +# -# cleanup cleanupTests -return diff --git a/tests/busy.test b/tests/busy.test index f535bfc..e7768d5 100644 --- a/tests/busy.test +++ b/tests/busy.test @@ -1,19 +1,27 @@ -# Tests for the tk busy command. -# -# This file contains a collection of tests for one or more of the Tk built-in -# commands. Sourcing this file runs the tests and generates output for errors. -# No output means no errors were found. +# This file is a Tcl script to test out the tk busy command. # # Copyright © 1998-2000 Jos Decoster. All rights reserved. -package require tcltest 2.2 -tcltest::configure {*}$argv -tcltest::loadTestedCommands -namespace import -force tcltest::test +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] -# There's currently no way to test the actual grab effect, per se, in an -# automated test. Therefore, this test suite only covers the interface to the -# grab command (ie, error messages, etc.) +# Ensure a pristine initial window state +resetWindows + +# +# TESTS +# test busy-1.1 {Tk_BusyObjCmd} -returnCodes error -body { tk busy @@ -504,6 +512,8 @@ test busy-8.3 {tk busy busywindow with a nonexisting widget} -body { tk busy forget . } -result {} +# +# TESTFILE CLEANUP +# ::tcltest::cleanupTests -return diff --git a/tests/button.test b/tests/button.test index 46cd15d..7ad19ec 100644 --- a/tests/button.test +++ b/tests/button.test @@ -1,22 +1,37 @@ # This file is a Tcl script to test labels, buttons, checkbuttons, and -# radiobuttons in Tk (i.e., all the widgets defined in tkButton.c). It is -# organized in the standard fashion for Tcl tests. +# radiobuttons in Tk (i.e., all the widgets defined in tkButton.c). # # Copyright © 1994 The Regents of the University of California. # Copyright © 1994-1996 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -eval tcltest::configure $argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import button image imageInit +# +# TESTS +# + test button-1.1 {configuration option: "activebackground" for label} -setup { label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .l @@ -2679,7 +2694,6 @@ test button-1.271 {configuration options: fallback to default} -setup { destroy .c } -result {0 0 0 0 0} -# ex-tests 3.* test button-2.1 {ButtonCreate - not enough arguments} -body { button } -returnCodes error -result {wrong # args: should be "button pathName ?-option value ...?"} @@ -2722,7 +2736,7 @@ test button-2.7 {ButtonCreate - bad window name} -body { } -cleanup { destroy foo } -returnCodes error -result {bad window path name "foo"} -######### test ex 3.8 + test button-2.8 {ButtonCreate procedure - error in default option value} -body { option add *funny.background bogus button .funny @@ -2753,7 +2767,6 @@ test button-2.11 {ButtonCreate procedure - option error} -body { } -cleanup { destroy .x } -result 0 -######### ex 3.10 test button-2.12 {ButtonCreate procedure - return value} -body { set x [button .abcd] return $x @@ -2761,7 +2774,6 @@ test button-2.12 {ButtonCreate procedure - return value} -body { destroy .abcd } -result {.abcd} -######### ex 4.* test button-3.1 {ButtonWidgetCmd - too few arguments} -body { button .b .b @@ -2839,7 +2851,6 @@ test button-3.12 {ButtonWidgetCmd procedure, "cget" option} -body { destroy .r } -returnCodes error -result {unknown option "-onvalue"} -# ex 4.6 test button-3.13 {ButtonWidgetCmd procedure, "configure" option} -body { button .b -highlightthickness 3 lindex [.b configure -highlightthickness] 4 @@ -3101,7 +3112,6 @@ test button-3.45 {ButtonWidgetCmd procedure, "select" option} -body { * ".r select"} red} -# ex 4.43 test button-3.46 {ButtonWidgetCmd procedure, "toggle" option} -body { label .l .l toggle @@ -3250,7 +3260,7 @@ test button-5.3 {ConfigureButton - textvariable trace} -body { } -cleanup { destroy .b } -result {From-y} -test button-5.4 {ConfigureButton - variable trace} -body { ;# ex 6.2a +test button-5.4 {ConfigureButton - variable trace} -body { checkbutton .c -variable x set x 1 set y 1 @@ -4008,13 +4018,12 @@ test button-15.3 {Bug [5d991b822e]} { } {} # -# CLEANUP +# TESTFILE CLEANUP # imageFinish testutils forget button image cleanupTests -return # Local variables: # mode: tcl diff --git a/tests/canvImg.test b/tests/canvImg.test index 69309fc..ff9af64 100644 --- a/tests/canvImg.test +++ b/tests/canvImg.test @@ -1,27 +1,45 @@ # This file is a Tcl script to test out the procedures in tkCanvImg.c, -# which implement canvas "image" items. It is organized in the standard -# fashion for Tcl tests. +# which implement canvas "image" items. # # Copyright © 1994 The Regents of the University of California. # Copyright © 1994-1996 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -eval tcltest::configure $argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import image imageInit -# Canvas used in every test case of the whole file +# +# COMMON TEST SETUP +# +# For every test case of the whole file +# canvas .c pack .c update +# +# TESTS +# test canvImg-1.1 {options for image items} -body { .c create image 50 50 -anchor nw -tags i1 @@ -386,11 +404,15 @@ test canvImg-7.2 {DisplayImage procedure, no image} -body { update } -result {} - -# image used in 8.* test cases +# +# COMMON TEST SETUP +# +# For tests canvImg-8.* +# if {[testConstraint testImageType]} { image create test foo } + test canvImg-8.1 {ImageToArea procedure} -constraints testImageType -setup { .c create image 50 100 -image foo -tags image -anchor nw .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {} @@ -553,6 +575,10 @@ test canvImg-8.18 {ImageToArea procedure} -constraints testImageType -setup { } -cleanup { .c delete all } -result {rect} + +# +# COMMON TEST CLEANUP +# .c delete all test canvImg-8.19 {ImageToArea procedure} -constraints testImageType -body { @@ -711,11 +737,14 @@ test canvImg-8.44 {ImageToArea procedure} -constraints testImageType -body { } -cleanup { .c delete all } -result {} + +# +# COMMON TEST SETUP +# if {[testConstraint testImageType]} { image delete foo } - test canvImg-9.1 {DisplayImage procedure} -constraints testImageType -setup { .c delete all image create test foo @@ -804,13 +833,12 @@ test canvImg-11.3 {ImageChangedProc procedure} -constraints { } -result {{foo2 display 0 0 80 60}} # -# CLEANUP +# TESTFILE CLEANUP # imageFinish testutils forget image cleanupTests -return # Local variables: # mode: tcl diff --git a/tests/canvMoveto.test b/tests/canvMoveto.test index 1ff1a0c..d4da911 100644 --- a/tests/canvMoveto.test +++ b/tests/canvMoveto.test @@ -6,14 +6,34 @@ # Copyright © 2004 Neil McKay. # All rights reserved. -package require tcltest 2.2 -eval tcltest::configure $argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] +# Ensure a pristine initial window state +resetWindows + +# +# COMMON TEST SETUP +# canvas .c -width 400 -height 300 -bd 2 -relief sunken .c create rectangle 20 20 80 80 -tag {test rect1} .c create rectangle 40 40 90 100 -tag {test rect2} +# +# TESTS +# + test canvMoveto-1.1 {Bad args handling for "moveto" command} -body { .c moveto test } -returnCodes error -result {wrong # args: should be ".c moveto tagOrId x y"} @@ -45,11 +65,12 @@ test canvMoveto-2.3 {Canvas "moveto" command, blank x coordinate} { .c bbox test } {200 200 272 282} -.c delete withtag all +# +# TESTFILE CLEANUP +# -# cleanup +.c delete withtag all cleanupTests -return # Local Variables: # mode: tcl diff --git a/tests/canvPs.test b/tests/canvPs.test index df5c340..a7e09bb 100644 --- a/tests/canvPs.test +++ b/tests/canvPs.test @@ -6,17 +6,37 @@ # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -eval tcltest::configure $argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import image imageInit -# canvas used in 1.* and 2.* test cases +# +# TESTS +# + +# +# COMMON TEST SETUP +# +# For tests canvas-1.* and canvas-2.* +# canvas .c -width 400 -height 300 -bd 2 -relief sunken .c create rectangle 20 20 80 80 -fill red pack .c @@ -134,8 +154,11 @@ test canvPs-2.4 {test writing to channel and file, same output} -constraints { removeFile foo.ps removeFile bar.ps } -result ok -destroy .c +# +# COMMON TEST CLEANUP +# +destroy .c test canvPs-3.1 {test ps generation with an embedded window} -setup { set bar [makeFile {} bar.ps] @@ -204,7 +227,7 @@ test canvPs-5.2 {test ps generation with image} -body { } -returnCodes ok -match glob -result * # -# CLEANUP +# TESTFILE CLEANUP # unset -nocomplain foo bar @@ -212,7 +235,6 @@ imageFinish testutils forget image deleteWindows cleanupTests -return # Local variables: # mode: tcl diff --git a/tests/canvRect.test b/tests/canvRect.test index 2e655e6..8b9acfa 100644 --- a/tests/canvRect.test +++ b/tests/canvRect.test @@ -1,23 +1,47 @@ # This file is a Tcl script to test out the procedures in tkRectOval.c, -# which implement canvas "rectangle" and "oval" items. It is organized -# in the standard fashion for Tcl tests. +# which implement canvas "rectangle" and "oval" items. # # Copyright © 1994-1996 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -eval tcltest::configure $argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows -# Canvas used in every test case of the whole file +# +# COMMON TEST SETUP +# +# For every test case of the whole file +# canvas .c -width 400 -height 300 -bd 2 -relief sunken pack .c update -# Rectangle used in canvRect-1.* tests +# +# TESTS +# + +# +# COMMON TEST SETUP +# +# For tests canvRect-1.* +# .c create rectangle 20 20 80 80 -tag test + test canvRect-1.1 {configuration options: good value for -fill} -body { .c itemconfigure test -fill #ff0000 list [.c itemcget test -fill] [lindex [.c itemconfigure test -fill] 4] @@ -54,8 +78,11 @@ test canvRect-1.9 {configuration options: good value for -width} -body { test canvRect-1.10 {configuration options: bad value for -width} -body { .c itemconfigure test -width abc } -returnCodes error -result {expected screen distance but got "abc"} -.c delete withtag all +# +# COMMON TEST CLEANUP +# +.c delete withtag all test canvRect-2.1 {CreateRectOval procedure} -body { .c create rect @@ -86,8 +113,11 @@ test canvRect-2.7 {CreateRectOval procedure} -body { test canvRect-2.8 {CreateRectOval procedure} -body { .c create rectangle 1 2 3 4 -gorp foo } -returnCodes error -result {unknown option "-gorp"} -.c delete withtag all +# +# COMMON TEST CLEANUP +# +.c delete withtag all test canvRect-3.1 {RectOvalCoords procedure} -body { .c create rectangle 10 20 30 40 -tags x @@ -167,20 +197,22 @@ test canvRect-4.4 {ConfigureRectOval procedure} -body { # I can't come up with any good tests for DeleteRectOval. +test canvRect-5.1.1 {ComputeRectOvalBbox procedure} -constraints nonwin -body { + .c create rectangle 10 20 30 40 -tags x -width 1 -outline {} + .c coords x 20 15 10 5 + .c bbox x +} -cleanup { + .c delete withtag all +} -result {10 5 20 15} # On Windows the bbox of rectangle items is 1 pixel larger at each border due # to the "bloat" implemented in ComputeRectOvalBbox() in case -outline is {} -if {[tk windowingsystem] eq "win32"} { - set result_5_1 {9 4 21 16} -} else { - set result_5_1 {10 5 20 15} -} -test canvRect-5.1 {ComputeRectOvalBbox procedure} -body { +test canvRect-5.1.2 {ComputeRectOvalBbox procedure} -constraints win32 -body { .c create rectangle 10 20 30 40 -tags x -width 1 -outline {} .c coords x 20 15 10 5 .c bbox x } -cleanup { .c delete withtag all -} -result $result_5_1 +} -result {9 4 21 16} test canvRect-5.2 {ComputeRectOvalBbox procedure} -body { .c create rectangle 10 20 30 40 -tags x -width 1 -outline {} .c coords x 10 20 30 10 @@ -463,10 +495,8 @@ end %%EOF } -# cleanup -cleanupTests -return - - - +# +# TESTFILE CLEANUP +# +cleanupTests diff --git a/tests/canvText.test b/tests/canvText.test index cf98bef..93a2c9a 100644 --- a/tests/canvText.test +++ b/tests/canvText.test @@ -1,23 +1,41 @@ # This file is a Tcl script to test out the procedures in tkCanvText.c, -# which implement canvas "text" items. It is organized in the standard -# fashion for Tcl tests. +# which implement canvas "text" items. # # Copyright © 1996-1997 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -eval tcltest::configure $argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# TESTS +# -# Canvas used in 1.* - 17.* tests +# +# COMMON TEST SETUP +# +# For tests canvas-1.* - 17.* +# canvas .c -width 400 -height 300 -bd 2 -relief sunken pack .c update - -# Item used in 1.* tests .c create text 20 20 -tag test + test canvText-1.1 {configuration options: good value for "anchor"} -body { .c itemconfigure test -anchor nw list [lindex [.c itemconfigure test -anchor] 4] [.c itemcget test -anchor] @@ -90,8 +108,11 @@ test canvasText-1.19 {configuration options: bounding of "angle"} -body { .c itemconfigure test -angle -360 lappend result [.c itemcget test -angle] } -result {30.0 330.0 0.0} -.c delete test +# +# COMMON TEST CLEANUP +# +.c delete test test canvText-2.1 {CreateText procedure: args} -body { .c create text @@ -378,14 +399,13 @@ test canvText-6.9 {ComputeTextBbox procedure} -constraints {fonts failsOnXQuartz .c delete test } -result 1 - -#.c delete test -#.c create text 20 20 -tag test -#focus -force .c -#.c focus test +# +# COMMON TEST SETUP +# focus .c .c focus test .c itemconfig test -text "abcd\nefghi\njklmnopq" + test canvText-7.1 {DisplayText procedure: stippling} -body { .c create text 20 20 -tag test .c itemconfig test -stipple gray50 @@ -585,8 +605,13 @@ test canvText-8.9 {TextInsert procedure: inserting after cursor} -setup { .c index test insert } -result 3 -# Item used in 9.* tests +# +# COMMON TEST SETUP +# +# For tests canvasText-9.* +# .c create text 20 20 -tag test + test canvText-9.1 {TextInsert procedure: before beginning/after end} -body { # Can't test this because GetTextIndex filters out those numbers. } -result {} @@ -686,8 +711,11 @@ test canvText-9.15 {TextInsert procedure: cursor doesn't move} -body { .c dchars test 7 9 .c index test insert } -result 5 -.c delete test +# +# COMMON TEST CLEANUP +# +.c delete test test canvText-10.1 {TextToPoint procedure} -body { .c create text 0 0 -tag test @@ -985,6 +1013,8 @@ test canvText-20.2 {crash on angled text selection (X11, without xft) - bug 2712 destroy .c } -result {} -# cleanup +# +# TESTFILE CLEANUP +# + cleanupTests -return diff --git a/tests/canvWind.test b/tests/canvWind.test index d1220b9..56617fa 100644 --- a/tests/canvWind.test +++ b/tests/canvWind.test @@ -1,15 +1,30 @@ # This file is a Tcl script to test out the procedures in tkCanvWind.c, -# which implement canvas "window" items. It is organized in the standard -# fashion for Tcl tests. +# which implement canvas "window" items. # # Copyright © 1997 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -eval tcltest::configure $argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# TESTS +# test canvWind-1.1 {DisplayWinItem, windows off-screen vertically} -setup { destroy .t @@ -155,6 +170,8 @@ test canvWind-2.1 {DisplayWinItem, window gets destroyed during <Configure>} -se destroy .t } -result {} -# cleanup +# +# TESTFILE CLEANUP +# + cleanupTests -return diff --git a/tests/canvas.test b/tests/canvas.test index 937ae60..22531c8 100644 --- a/tests/canvas.test +++ b/tests/canvas.test @@ -1,25 +1,76 @@ # This file is a Tcl script to test out the procedures in tkCanvas.c, which -# implements generic code for canvases. It is organized in the standard -# fashion for Tcl tests. +# implements generic code for canvases. # # Copyright © 1995-1996 Sun Microsystems, Inc. # Copyright © 1998-2000 Ajuba Solutions. # Copyright © 2008 Donal K. Fellows # All rights reserved. -package require tcltest 2.2 -eval tcltest::configure $argv -tcltest::loadTestedCommands +# NOTE +# +# This test file is woefully incomplete. At present, only a few of the +# features are tested. + +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import image imageInit -# XXX - This test file is woefully incomplete. At present, only a few of the -# features are tested. +# +# LOCAL UTILITY PROCS +# + +proc kill_canvas {w} { + destroy $w + pack [canvas $w -height 200 -width 200] -fill both -expand yes + update idle + $w create rectangle 80 80 120 120 -fill blue -tags blue + # bind a button press to re-build the canvas + $w bind blue <ButtonRelease-1> [subst { + [lindex [info level 0] 0] $w + append ::x ok + }] +} -# Canvas used in 1.* test cases +proc matchPixels {pixels expected} { + set matched 1 + foreach pline $pixels eline $expected { + foreach ppixel $pline epixel $eline { + if {$ppixel != $epixel} { + set matched 0 + break + } + } + } + return $matched +} + +# +# TESTS +# + +# +# COMMON TEST SETUP +# +# For tests canvas-1.* +# canvas .c pack .c update @@ -191,9 +242,13 @@ test canvas-1.47 {configure throws error on bad option} -body { .c create rect 10 10 100 100 .c configure -gorp foo } -returnCodes error -match glob -result {*} -catch {destroy .c} -# Canvas used in 2.* test cases +# +# COMMON TEST SETUP +# +# For tests canvas-2.* +# +catch {destroy .c} canvas .c -width 60 -height 40 -scrollregion {0 0 200 150} -bd 0 \ -highlightthickness 0 pack .c @@ -239,9 +294,13 @@ test canvas-2.5 {CanvasWidgetCmd, raise/lower option, no error on non-existing t } -cleanup { .c delete aline } -result {} -catch {destroy .c} -# Canvas used in 3.* test cases +# +# COMMON TEST SETUP +# +# For tests canvas-3.* +# +catch {destroy .c} canvas .c -width 60 -height 40 -scrollregion {0 0 200 80} \ -borderwidth 0 -highlightthickness 0 pack .c @@ -265,6 +324,10 @@ test canvas-3.2 {CanvasWidgetCmd, yview option} -body { update lappend x [.c yview] } -result {{0.0 0.5} {0.1 0.6}} + +# +# COMMON TEST CLEANUP +# destroy .c test canvas-4.1 {ButtonEventProc procedure} -setup { @@ -287,7 +350,11 @@ test canvas-5.1 {ButtonCmdDeletedProc procedure} -body { destroy .c1 } -result {{} {}} -# Canvas used in 6.* test cases +# +# COMMON TEST SETUP +# +# For tests canvas-6.* +# canvas .c -width 100 -height 50 -scrollregion {-200 -100 305 102} \ -borderwidth 2 -highlightthickness 3 pack .c @@ -330,6 +397,10 @@ test canvas-6.5 {CanvasSetOrigin procedure} -body { .c yview moveto 1.0 .c canvasy 0 } -result {55.0} + +# +# COMMON TEST CLEANUP +# deleteWindows test canvas-7.1 {canvas widget vs hidden commands} -setup { @@ -592,18 +663,6 @@ test canvas-12.2 {canvas mm obj, patch SF-403327, 102471} -setup { incr val } -result 12 -# procedure used in 13.1 test case -proc kill_canvas {w} { - destroy $w - pack [canvas $w -height 200 -width 200] -fill both -expand yes - update idle - $w create rectangle 80 80 120 120 -fill blue -tags blue - # bind a button press to re-build the canvas - $w bind blue <ButtonRelease-1> [subst { - [lindex [info level 0] 0] $w - append ::x ok - }] -} test canvas-13.1 {canvas delete during event, SF bug-228024} -body { kill_canvas .c set ::x {} @@ -783,6 +842,10 @@ test canvas-15.21 {bug [237971ce]} -setup { .c insert $id end {200 200} .c coords $id } -result {0.0 0.0 50.0 50.0 100.0 50.0 200.0 200.0} + +# +# COMMON TEST CLEANUP +# destroy .c test canvas-16.1 {arc coords check} -setup { @@ -1045,7 +1108,11 @@ test canvas-20.3 {tag deletion - all tags match} -setup { destroy .c } -result {{tagA tagA tagA tagA tagA tagA} {}} +# +# COMMON TEST CLEANUP +# destroy .c + test canvas-21.1 {canvas rotate} -setup { pack [canvas .c] } -body { @@ -1228,20 +1295,6 @@ test canvas-22.9 {canvas rotate: window item rotation behaviour} -setup { destroy .c } -result {{50.00 150.00} {} {25 125 50 150}} -# Procedure used in test cases 23.1 23.2 23.3 -proc matchPixels {pixels expected} { - set matched 1 - foreach pline $pixels eline $expected { - foreach ppixel $pline epixel $eline { - if {$ppixel != $epixel} { - set matched 0 - break - } - } - } - return $matched -} - test canvas-23.1 {canvas image} -setup { canvas .c image create photo testimage @@ -1317,13 +1370,12 @@ test canvas-23.3 {canvas image with subsample and zoom} -setup { } -result 1 # -# CLEANUP +# TESTFILE CLEANUP # imageCleanup testutils forget image cleanupTests -return # Local Variables: # mode: tcl diff --git a/tests/choosedir.test b/tests/choosedir.test index 172aa2b..f114789 100644 --- a/tests/choosedir.test +++ b/tests/choosedir.test @@ -1,27 +1,32 @@ -# This file is a Tcl script to test out Tk's "tk_chooseDir" and -# It is organized in the standard fashion for Tcl tests. +# This file is a Tcl script to test out Tk's "tk_chooseDir". # # Copyright © 1996 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -eval tcltest::configure $argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import dialog -#---------------------------------------------------------------------- # -# Procedures needed by this test file +# LOCAL UTILITY PROCS # -#---------------------------------------------------------------------- - -proc ToEnterDirsByKey {parent dirs} { - after 100 [list EnterDirsByKey $parent $dirs] -} proc EnterDirsByKey {parent dirs} { if {$parent == "."} { @@ -40,17 +45,22 @@ proc EnterDirsByKey {parent dirs} { } } -#---------------------------------------------------------------------- +proc ToEnterDirsByKey {parent dirs} { + after 100 [list EnterDirsByKey $parent $dirs] +} + # -# The test suite proper +# COMMON TEST SETUP # -#---------------------------------------------------------------------- +set parent . + # Make a dir for us to rely on for tests set real [makeDirectory choosedirTest] -set dir [file dirname $real] -set fake [file join $dir non-existant] +set fake [file join [file dirname $real] non-existant] -set parent . +# +# TESTS +# test choosedir-1.1 {tk_chooseDirectory command} -body { tk_chooseDirectory -initialdir @@ -136,10 +146,10 @@ test choosedir-5.1 {tk_chooseDirectory, handles {} entry text} -constraints { } -result $real # -# CLEANUP +# TESTFILE CLEANUP # +unset fake parent real removeDirectory choosedirTest testutils forget dialog cleanupTests -return diff --git a/tests/clipboard.test b/tests/clipboard.test index 88e309e..4771d3e 100644 --- a/tests/clipboard.test +++ b/tests/clipboard.test @@ -1,29 +1,41 @@ # This file is a Tcl script to test out Tk's clipboard management code, -# especially the "clipboard" command. It is organized in the standard -# fashion for Tcl tests. +# especially the "clipboard" command. # # Copyright © 1994 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. +# NOTES # -# Note: Multiple display clipboard handling will only be tested if the -# environment variable TK_ALT_DISPLAY is set to an alternate display. +# * Multiple display clipboard handling will only be tested if the environment +# variable TK_ALT_DISPLAY is set to an alternate display. +# * Some of these tests may fail if another application is grabbing the +# clipboard (e.g. an X server, or a VNC viewer) + +# +# TESTFILE INITIALIZATION # -################################################################# -# Note that some of these tests may fail if another application # -# is grabbing the clipboard (e.g. an X server, or a VNC viewer) # -################################################################# +package require tcltest 2.2; # needed in mode -singleproc 0 -package require tcltest 2.2 -namespace import ::tcltest::* -eval tcltest::configure $argv -tcltest::loadTestedCommands +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import child +# +# COMMON TEST SETUP +# + # set up a very large buffer to test INCR retrievals set longValue "" foreach i {a b c d e f g j h i j k l m o p q r s t u v w x y z} { @@ -31,7 +43,9 @@ foreach i {a b c d e f g j h i j k l m o p q r s t u v w x y z} { append longValue A$j B$j C$j D$j E$j F$j G$j H$j I$j K$j L$j M$j N$j } -# Now we start the main body of the test code +# +# TESTS +# test clipboard-1.1 {ClipboardHandler procedure} -setup { clipboard clear @@ -359,12 +373,11 @@ test clipboard-7.20 {Tk_ClipboardCmd procedure} -setup { } -result {-type} # -# CLEANUP +# TESTFILE CLEANUP # testutils forget child cleanupTests -return # Local Variables: # mode: tcl diff --git a/tests/clrpick.test b/tests/clrpick.test index 2e8d0bf..f06703b 100644 --- a/tests/clrpick.test +++ b/tests/clrpick.test @@ -1,18 +1,33 @@ # This file is a Tcl script to test out Tk's "tk_chooseColor" command. -# It is organized in the standard fashion for Tcl tests. # # Copyright © 1996 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -eval tcltest::configure $argv -tcltest::loadTestedCommands -namespace import -force tcltest::test +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import dialog +# +# LOCAL TEST CONSTRAINTS +# + if {[testConstraint defaultPseudocolor8]} { # let's soak up a bunch of colors...so that # machines with small color palettes still fail. @@ -47,6 +62,41 @@ if {[testConstraint defaultPseudocolor8]} { testConstraint colorsLeftover 1 } +# +# LOCAL UTILITY PROCS +# + +proc ChooseColorByKey {parent r g b} { + set w .__tk__color + upvar ::tk::dialog::color::[winfo name $w] data + + update + $data(red,entry) delete 0 end + $data(green,entry) delete 0 end + $data(blue,entry) delete 0 end + + $data(red,entry) insert 0 $r + $data(green,entry) insert 0 $g + $data(blue,entry) insert 0 $b + + # Manually force the refresh of the color values instead + # of counting on the timing of the event stream to change + # the values for us. + tk::dialog::color::HandleRGBEntry $w + + SendButtonPress . ok mouse +} + +proc ToChooseColorByKey {parent r g b} { + if {! $::dialogIsNative} { + after 200 ChooseColorByKey . $r $g $b + } +} + +# +# TESTS +# + test clrpick-1.1 {tk_chooseColor command} -body { tk_chooseColor -foo } -returnCodes error -result {bad option "-foo": must be -initialcolor, -parent, or -title} @@ -77,33 +127,6 @@ test clrpick-1.7 {tk_chooseColor command} -body { tk_chooseColor -initialcolor ##badbadbaadcolor } -returnCodes error -result {invalid color name "##badbadbaadcolor"} -proc ToChooseColorByKey {parent r g b} { - if {! $::dialogIsNative} { - after 200 ChooseColorByKey . $r $g $b - } -} - -proc ChooseColorByKey {parent r g b} { - set w .__tk__color - upvar ::tk::dialog::color::[winfo name $w] data - - update - $data(red,entry) delete 0 end - $data(green,entry) delete 0 end - $data(blue,entry) delete 0 end - - $data(red,entry) insert 0 $r - $data(green,entry) insert 0 $g - $data(blue,entry) insert 0 $b - - # Manually force the refresh of the color values instead - # of counting on the timing of the event stream to change - # the values for us. - tk::dialog::color::HandleRGBEntry $w - - SendButtonPress . ok mouse -} - test clrpick-2.1 {tk_chooseColor command} -constraints { nonUnixUserInteraction colorsLeftover } -setup { @@ -160,9 +183,8 @@ test clrpick-4.1 {tk_chooseColor: screen is inherited from parent} -constraints } -result [winfo screen .] # -# CLEANUP +# TESTFILE CLEANUP # testutils forget dialog cleanupTests -return diff --git a/tests/cluster.test b/tests/cluster.test index 1ef9424..f535791 100644 --- a/tests/cluster.test +++ b/tests/cluster.test @@ -1,18 +1,36 @@ # This file is a Tcl script to test the [::tk::startOf|endOf]* functions in -# tk.tcl and tkIcu.c. It is organized in the standard fashion for Tcl tests. +# tk.tcl and tkIcu.c. # # Copyright © 1994 The Regents of the University of California. # Copyright © 1994-1995 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -eval tcltest::configure $argv -tcltest::loadTestedCommands -namespace import -force tcltest::test +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# LOCAL TEST CONSTRAINTS +# testConstraint needsICU [expr {[catch {info body ::tk::startOfCluster}]}] +# +# TESTS +# test cluster-1.0 {::tk::startOfCluster} -body { ::tk::startOfCluster é -1 @@ -242,5 +260,8 @@ test cluster-8.6 {::tk::wordBreakAfter} -body { ::tk::wordBreakAfter a b c d } -returnCodes 1 -result {wrong # args: should be "::tk::wordBreakAfter str start ?locale?"} +# +# TESTFILE CLEANUP +# + cleanupTests -return diff --git a/tests/cmds.test b/tests/cmds.test index 8a1ff2a..1fcf047 100644 --- a/tests/cmds.test +++ b/tests/cmds.test @@ -1,17 +1,36 @@ # This file is a Tcl script to test the procedures in the file -# tkCmds.c. It is organized in the standard fashion for Tcl tests. +# tkCmds.c. # # Copyright © 1996 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -eval tcltest::configure $argv -tcltest::loadTestedCommands -namespace import -force tcltest::test +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] +# Ensure a pristine initial window state +resetWindows + +# +# COMMON TEST SETUP +# update +# +# TESTS +# + test cmds-1.1 {tkwait visibility, argument errors} -body { tkwait visibility } -returnCodes error -result {wrong # args: should be "tkwait variable|visibility|window name"} @@ -53,8 +72,8 @@ test cmds-1.6 {tkwait visibility, window gets deleted} -setup { destroy .f } -result {deleted} +# +# TESTFILE CLEANUP +# -# cleanup cleanupTests -return - diff --git a/tests/color.test b/tests/color.test index 75ed035..648b22d 100644 --- a/tests/color.test +++ b/tests/color.test @@ -1,23 +1,65 @@ # This file is a Tcl script to test out the procedures in the file -# tkColor.c. It is organized in the standard fashion for Tcl tests. +# tkColor.c. # # Copyright © 1995-1998 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -eval tcltest::configure $argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import colors +# +# LOCAL UTILITY PROCS +# + +# c255 - +# Given a list of red, green, and blue intensities, scale them +# down to a 0-255 range. +# +# Arguments: +# vals - List of intensities. + +proc c255 {vals} { + list [expr {[lindex $vals 0]/256}] [expr {[lindex $vals 1]/256}] \ + [expr {[lindex $vals 2]/256}] +} + +# closest - +# Given intensities between 0 and 255, return the closest intensities +# that the server can provide. +# +# Arguments: +# w - Window in which to lookup color +# r, g, b - Desired intensities, between 0 and 255. + +proc closest {w r g b} { + set vals [winfo rgb $w [cname $r $g $b]] + list [expr [lindex $vals 0]/256] [expr [lindex $vals 1]/256] \ + [expr [lindex $vals 2]/256] +} + # cname -- # Returns a proper name for a color, given its intensities. # # Arguments: # r, g, b - Intensities on a 0-255 scale. - proc cname {r g b} { format #%02x%02x%02x $r $g $b } @@ -51,31 +93,9 @@ proc mkColors {c width height r g b rx gx bx ry gy by} { } } -# closest - -# Given intensities between 0 and 255, return the closest intensities -# that the server can provide. # -# Arguments: -# w - Window in which to lookup color -# r, g, b - Desired intensities, between 0 and 255. - -proc closest {w r g b} { - set vals [winfo rgb $w [cname $r $g $b]] - list [expr [lindex $vals 0]/256] [expr [lindex $vals 1]/256] \ - [expr [lindex $vals 2]/256] -} - -# c255 - -# Given a list of red, green, and blue intensities, scale them -# down to a 0-255 range. +# LOCAL TEST CONSTRAINTS # -# Arguments: -# vals - List of intensities. - -proc c255 {vals} { - list [expr {[lindex $vals 0]/256}] [expr {[lindex $vals 1]/256}] \ - [expr {[lindex $vals 2]/256}] -} # -- WARNING (SB, 6.4.2017) -- # @@ -86,7 +106,7 @@ proc c255 {vals} { # The problem is, on machines with a fancy 24 truecolor display, the # 'colorsFree' constraint doesn't get set, turning off pretty much every test # in this file. - +# if {[testConstraint pseudocolor8]} { toplevel .t -visual {pseudocolor 8} -colormap new wm geom .t +0+0 @@ -104,6 +124,10 @@ if {[testConstraint pseudocolor8]} { destroy .t.c .t.c2 } +# +# TESTS +# + test color-1.1 {Tk_AllocColorFromObj - converting internal reps} colorsFree { set x green lindex $x 0 @@ -290,12 +314,10 @@ test color-4.1 {FreeColorObjProc} -constraints { rename copy {} } -result {{{1 3}} {{1 2}} {{1 1}} {}} -destroy .t - # -# CLEANUP +# TESTFILE CLEANUP # +destroy .t testutils forget colors cleanupTests -return diff --git a/tests/config.test b/tests/config.test index 649c6f6..3d9857a 100644 --- a/tests/config.test +++ b/tests/config.test @@ -1,15 +1,30 @@ # This file is a Tcl script to test the procedures in tkConfig.c, -# which comprise the new new option configuration system. It is -# organized in the standard "white-box" fashion for Tcl tests. +# which comprise the new new option configuration system. # # Copyright © 1997 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -eval tcltest::configure $argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# LOCAL UTILITY PROCS +# proc killTables {} { # Note: it's important to delete chain2 before chain1, because @@ -24,7 +39,13 @@ proc killTables {} { } } +# +# TESTS +# +# +# COMMON TEST SETUP +# option clear deleteWindows if {[testConstraint testobjconfig]} { @@ -136,8 +157,6 @@ test config-2.1 {Tk_DeleteOptionTable - reference counts} -constraints { killTables } -result {{3 4 -three 2 2 -one} {2 2 -one} {} {2 2 -one}} -# No tests for DestroyOptionHashTable; couldn't figure out how to test. - test config-3.1 {Tk_InitOptions - priority of chained tables} -constraints { testobjconfig } -body { @@ -1191,10 +1210,13 @@ test config-6.6 {GetOptionFromObj - synonym} -constraints testobjconfig -body { killTables } -result red - +# +# COMMON TEST SETUP +# if {[testConstraint testobjconfig]} { testobjconfig alltypes .a } + test config-7.1 {Tk_SetOptions - basics} -constraints testobjconfig -body { .a configure -color green -rel sunken list [.a cget -color] [.a cget -relief] @@ -1279,11 +1301,14 @@ test config-7.14 {Tk_SetOptions - error in DoObjConfig with custom option} -cons (processing "-custom" option) invoked from within ".a configure -custom bad"} + +# +# COMMON TEST CLEANUP +# if {[testConstraint testobjconfig]} { killTables } - test config-8.1 {Tk_RestoreSavedOptions - restore in proper order} -constraints { testobjconfig } -body { @@ -1559,11 +1584,14 @@ test config-9.13 {Tk_FreeConfigOptions/FreeResources - custom internal form} -co .foo configure -custom "foobar" destroy .foo } -result {} + +# +# COMMON TEST CLEANUP +# if {[testConstraint testobjconfig]} { killTables } - test config-10.1 {Tk_GetOptionInfo - one item} -constraints testobjconfig -body { testobjconfig alltypes .foo .foo configure -anchor e @@ -1594,14 +1622,15 @@ test config-10.4 {Tk_GetOptionInfo - chaining through tables} -constraints testo } -cleanup { destroy .foo } -result {{-three three Three three xyzzy} {-four four Four four four} {-two two Two {two and a half} {two and a half}} {-oneAgain oneAgain OneAgain {one again} {one again}} {-one one One one asdf} {-two two Two two {two and a half}}} -if {[testConstraint testobjconfig]} { - killTables -} - +# +# COMMON TEST SETUP +# if {[testConstraint testobjconfig]} { + killTables testobjconfig alltypes .a } + test config-11.1 {GetConfigList - synonym} -constraints testobjconfig -body { lindex [.a configure] end } -result {-synonym -color} @@ -1615,14 +1644,15 @@ test config-11.3 {GetConfigList - null default and current value} -constraints { } -body { .a configure -relief } -result {-relief relief Relief {} {}} -if {[testConstraint testobjconfig]} { - killTables -} - +# +# COMMON TEST SETUP +# if {[testConstraint testobjconfig]} { + killTables testobjconfig internal .a } + test config-12.1 {GetObjectForOption - boolean} -constraints testobjconfig -body { .a configure -boolean 0 .a cget -boolean @@ -1704,11 +1734,14 @@ test config-12.17 {GetObjectForOption - null values} -constraints { [.a cget -bitmap] [.a cget -border] [.a cget -cursor] \ [.a cget -window] [.a cget -custom] } -result {{} {} {} {} {} {} {} {}} + +# +# COMMON TEST CLEANUP +# if {[testConstraint testobjconfig]} { killTables } - test config-13.1 {proper cleanup of options with widget destroy} -body { button .w -cursor crosshair destroy .w @@ -1917,19 +1950,12 @@ test config-14.14 {Tk_CreateOptionTable - use with namespace import} -setup { destroy .a .b } -result {} +# +# TESTFILE CLEANUP +# -# cleanup deleteWindows if {[testConstraint testobjconfig]} { killTables } cleanupTests -return - - - - - - - - diff --git a/tests/constraints.tcl b/tests/constraints.tcl index 660fe47..e979aca 100644 --- a/tests/constraints.tcl +++ b/tests/constraints.tcl @@ -10,11 +10,22 @@ namespace import -force tcltest::testConstraint # +# OPERATING SYSTEM +# +testConstraint failsOnUbuntu [expr {![info exists ::env(CI)] || ![string match Linux $::tcl_platform(os)]}] +if {$tcl_platform(os) eq "Darwin"} { + scan $tcl_platform(osVersion) "%d" macosVersion +} +testConstraint notMacosSequoiaOrOlder [expr {($tcl_platform(os) ne "Darwin") || ($macosVersion > 24)}] +unset -nocomplain macosVersion + +# # WINDOWING SYSTEM AND DISPLAY # testConstraint notAqua [expr {[tk windowingsystem] ne "aqua"}] testConstraint aqua [expr {[tk windowingsystem] eq "aqua"}] testConstraint x11 [expr {[tk windowingsystem] eq "x11"}] +testConstraint win32 [expr {[tk windowingsystem] eq "win32"}] testConstraint nonwin [expr {[tk windowingsystem] ne "win32"}] testConstraint aquaOrWin32 [expr { ([tk windowingsystem] eq "win32") || [testConstraint aqua] @@ -42,7 +53,6 @@ if {[llength [info commands send]]} { childTkProcess exit testutils forget child -testConstraint failsOnUbuntu [expr {![info exists ::env(CI)] || ![string match Linux $::tcl_platform(os)]}] testConstraint failsOnXQuartz [expr {$tcl_platform(os) ne "Darwin" || [tk windowingsystem] ne "x11" }] # diff --git a/tests/cursor.test b/tests/cursor.test index f84232c..ddd2576 100644 --- a/tests/cursor.test +++ b/tests/cursor.test @@ -1,16 +1,31 @@ # This file is a Tcl script to test out the procedures in the file -# tkCursor.c. It is organized in the standard white-box fashion for -# Tcl tests. +# tkCursor.c. # # Copyright © 1998 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -eval tcltest::configure $argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] +# Ensure a pristine initial window state +resetWindows + + +# +# LOCAL UTILITY PROCS +# # Tests 2.3 and 2.4 need a helper file with a very specific name and # controlled format. @@ -47,6 +62,9 @@ proc setWincur {wincurName} { set wincur(file) [makeFile $wincur(data_binary) "test file.cur" $wincur(dir)] } +# +# TESTS +# test cursor-1.1 {Tk_AllocCursorFromObj - converting internal reps} -constraints { testcursor @@ -839,8 +857,8 @@ test cursor-7.9 {check Windows cursor wait} -constraints win -setup { destroy .b } -result {} -# ------------------------------------------------------------------------- +# +# TESTFILE CLEANUP +# -# cleanup cleanupTests -return diff --git a/tests/dialog.test b/tests/dialog.test index d78d825..78105d9 100644 --- a/tests/dialog.test +++ b/tests/dialog.test @@ -1,14 +1,29 @@ # This file is a Tcl script to test out Tk's "tk_dialog" command. -# It is organized in the standard fashion for Tcl tests. -package require tcltest 2.2 -eval tcltest::configure $argv -tcltest::loadTestedCommands -namespace import -force tcltest::test +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import dialog +# +# TESTS +# + test dialog-1.1 {tk_dialog command} -body { tk_dialog } -match glob -returnCodes error -result {wrong # args: should be "tk_dialog w title text bitmap default *"} @@ -61,9 +76,8 @@ test dialog-2.3 {tk_dialog operation} -body { } -result -1 # -# CLEANUP +# TESTFILE CLEANUP # testutils forget dialog cleanupTests -return diff --git a/tests/embed.test b/tests/embed.test index 8a61baf..0c66720 100644 --- a/tests/embed.test +++ b/tests/embed.test @@ -4,11 +4,26 @@ # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -eval tcltest::configure $argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# TESTS +# test embed-1.1 {Tk_UseWindow procedure, bad window identifier} -setup { deleteWindows @@ -81,8 +96,8 @@ test embed-1.5.nonwin {Tk_UseWindow procedure, -container must be set} -constrai deleteWindows } -returnCodes error -result {window ".container" doesn't have -container option set} +# +# TESTFILE CLEANUP +# cleanupTests -return - - diff --git a/tests/entry.test b/tests/entry.test index 701bb29..a765b2a 100644 --- a/tests/entry.test +++ b/tests/entry.test @@ -1,24 +1,47 @@ -# This file is a Tcl script to test entry widgets in Tk. It is -# organized in the standard fashion for Tcl tests. +# This file is a Tcl script to test entry widgets in Tk. # # Copyright © 1994 The Regents of the University of California. # Copyright © 1994-1997 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -eval tcltest::configure $argv -tcltest::loadTestedCommands +# NOTE +# +# Gathered comments about lacks +# Still need to write tests for EntryBlinkProc, EntryFocusProc, +# EntryTextVarProc, EntryScanTo and EntrySelectTo, DisplayEntry, EventuallyRedraw. + +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script "main.tcl", which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import entry scroll +# +# COMMON TEST SETUP +# + foreach i {1 2 3} { set validateCmd$i [list validateCommand$i %W %d %i %P %s %S %v %V] } set cy [font metrics {Courier -12} -linespace] +# +# TESTS +# test entry-1.1 {configuration option: "background" for entry} -setup { entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} @@ -2851,7 +2874,7 @@ test entry-13.26 {GetEntryIndex procedure} -constraints fonts -body { destroy .e } -result {0 1} -# XXX Still need to write tests for EntryScanTo and EntrySelectTo. +# Still need to write tests for EntryScanTo and EntrySelectTo. test entry-14.1 {EntryFetchSelection procedure} -body { @@ -3331,7 +3354,7 @@ test entry-19.17 {entry widget validation} -setup { } -result {focusout {.e -1 -1 newdata abcd {} focusout forced}} -# proc doval changed - returns 0 +# Using validateCmd3, which returns 0 test entry-19.18 {entry widget validation} -setup { unset -nocomplain textVar validationData } -body { @@ -3351,7 +3374,7 @@ test entry-19.18 {entry widget validation} -setup { ## This sets validate to none because it shows that we prevent a possible ## loop condition in the validation, when the entry textvar is also set -# proc doval2 used +# Using validateCmd2 test entry-19.19 {entry widget validation} -setup { unset -nocomplain textVar validationData } -body { @@ -3596,16 +3619,8 @@ test entry-25.3 {Bug [2a32225cd1] - Navigation in a password made of several wor destroy .e } -result {{} {}} - -# Gathered comments about lacks -# XXX Still need to write tests for EntryBlinkProc, EntryFocusProc, -# and EntryTextVarProc. -# No tests for DisplayEntry. -# XXX Still need to write tests for EntryScanTo and EntrySelectTo. -# No tests for EventuallyRedraw - # -# CLEANUP +# TESTFILE CLEANUP # # option clear @@ -3615,5 +3630,4 @@ foreach i {1 2 3} { unset i testutils forget entry scroll cleanupTests -return diff --git a/tests/event.test b/tests/event.test index 316c3b9..dce2592 100644 --- a/tests/event.test +++ b/tests/event.test @@ -1,22 +1,55 @@ -# This file is a Tcl script to test the code in tkEvent.c. It is -# organized in the standard fashion for Tcl tests. +# This file is a Tcl script to test the code in tkEvent.c. # # Copyright © 1994 The Regents of the University of California. # Copyright © 1994-1995 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -eval tcltest::configure $argv -tcltest::loadTestedCommands -namespace import -force tcltest::test - -# XXX This test file is woefully incomplete. Right now it only tests +# NOTE +# +# This test file is woefully incomplete. Right now it only tests # a few of the procedures in tkEvent.c. Please add more tests whenever # possible. -# Setup table used to query key events. +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# LOCAL UTILITY PROCS +# + +# _get_selection -- +# +# Return selection only if owned by the given widget +# +proc _get_selection {widget} { + if {[string compare $widget [selection own]] != 0} { + return "" + } + if {[catch {selection get} sel]} { + return "" + } + return $sel +} +# _init_keypress_lookup -- +# +# Setup table used to query key events. +# proc _init_keypress_lookup {} { global keypress_lookup @@ -39,34 +72,10 @@ proc _init_keypress_lookup {} { "\t" Tab] } -# Lookup an event in the keypress table. -# For example: -# Q -> Q -# ; -> semicolon -# > -> greater -# Delete -> Delete -# Escape -> Escape - -proc _keypress_lookup {char} { - global keypress_lookup - - if {! [info exists keypress_lookup]} { - _init_keypress_lookup - } - - if {$char == ""} { - error "empty char" - } - - if {[info exists keypress_lookup($char)]} { - return $keypress_lookup($char) - } else { - return $char - } -} - -# Lookup and generate a pair of Key and KeyRelease events - +# _keypress -- +# +# Lookup and generate a pair of Key and KeyRelease events +# proc _keypress {win key} { set keysym [_keypress_lookup $key] @@ -87,16 +96,49 @@ proc _keypress {win key} { pause 50 } -# Call _keypress for each character in the given string +# _keypress_lookup -- +# +# Lookup an event in the keypress table. +# +# For example: +# Q -> Q +# ; -> semicolon +# > -> greater +# Delete -> Delete +# Escape -> Escape +# +proc _keypress_lookup {char} { + global keypress_lookup + + if {! [info exists keypress_lookup]} { + _init_keypress_lookup + } + + if {$char == ""} { + error "empty char" + } + + if {[info exists keypress_lookup($char)]} { + return $keypress_lookup($char) + } else { + return $char + } +} +# _keypress_string -- +# +# Call _keypress for each character in the given string +# proc _keypress_string {win string} { foreach letter [split $string ""] { _keypress $win $letter } } -# Helper proc to convert index to x y position - +# _text_ind_to_x_y -- +# +# Helper proc to convert index to x y position +# proc _text_ind_to_x_y {text ind} { set bbox [$text bbox $ind] if {[llength $bbox] != 4} { @@ -107,19 +149,80 @@ proc _text_ind_to_x_y {text ind} { return [list $x1 $middle_y] } -# Return selection only if owned by the given widget +proc create_and_pack_frames {{w {}}} { + frame $w.f1 -bg blue -width 200 -height 200 + pack propagate $w.f1 0 + frame $w.f1.f2 -bg yellow -width 100 -height 100 + pack $w.f1.f2 $w.f1 -side bottom -anchor se + update idletasks +} -proc _get_selection {widget} { - if {[string compare $widget [selection own]] != 0} { - return "" +# setup_win_mousepointer -- +# +# Position the window and the mouse pointer as an initial state for some tests. +# The so-called "pointer window" is the $w window that will now contain the mouse pointer. +# +proc setup_win_mousepointer {w} { + wm geometry . +700+400; # root window out of our way - must not cover windows from event-9.1* + toplevel $w + pack propagate $w 0 + wm geometry $w 300x300+100+100 + tkwait visibility $w + update; # service remaining screen drawing events (e.g. <Expose>) + set pointerWin [winfo containing [winfo pointerx $w] [winfo pointery $w]] + event generate $w <Motion> -warp 1 -x 250 -y 250 + if {($pointerWin ne $w) && ([tk windowingsystem] ne "aqua")} { + waitForWindowEvent $w <Enter> + } else { + controlPointerWarpTiming } - if {[catch {selection get} sel]} { - return "" +} + +# waitForWindowEvent -- +# +# This proc is intended to overcome latency of windowing system +# notifications when toplevel windows are involved. These latencies vary +# considerably with the window manager in use, with the system load, +# with configured scheduling priorities for processes, etc ... +# Waiting for the corresponding window events evades the trouble that is +# associated with the alternative: waiting or halting the Tk process for a +# fixed amount of time (using "after ms"). With the latter strategy it's +# always a gamble how much waiting time is enough on an end user's system. +# It also leads to long fixed waiting times in order to be on the safe side. +# +proc waitForWindowEvent {w event {timeout 1000}} { + + variable _windowEvent + + # Use counter as a unique ID to prevent subsequent waits + # from interfering with each other. + set counter [incr _windowEvent(counter)] + set _windowEvent($counter) 1 + set savedBinding [bind $w $event] + bind $w $event [list +waitForWindowEvent.signal $counter] + set afterID [after $timeout [list set _windowEvent($counter) -1]] + vwait _windowEvent($counter) + set late [expr {$_windowEvent($counter) == -1}] + bind $w $event $savedBinding + unset _windowEvent($counter) + if {$late} { + puts stderr "wait for $event event on $w timed out (> $timeout ms)" + } else { + after cancel $afterID } - return $sel } -# Begining of the actual tests +# waitForWindowEvent.signal-- +# +# Helper proc that records the triggering of a window event. +# +proc waitForWindowEvent.signal {counter} { + incr ::_windowEvent($counter) +} + +# +# TESTS +# test event-1.1 {Tk_HandleEvent procedure, filter events for dead windows} -setup { deleteWindows @@ -864,67 +967,6 @@ test event-9.2 {enter toplevel window by destroying a toplevel - bug b1d115fa60} } } -result {.top1} -proc waitForWindowEvent {w event {timeout 1000}} { -# This proc is intended to overcome latency of windowing system -# notifications when toplevel windows are involved. These latencies vary -# considerably with the window manager in use, with the system load, -# with configured scheduling priorities for processes, etc ... -# Waiting for the corresponding window events evades the trouble that is -# associated with the alternative: waiting or halting the Tk process for a -# fixed amount of time (using "after ms"). With the latter strategy it's -# always a gamble how much waiting time is enough on an end user's system. -# It also leads to long fixed waiting times in order to be on the safe side. - - variable _windowEvent - - # Use counter as a unique ID to prevent subsequent waits - # from interfering with each other. - set counter [incr _windowEvent(counter)] - set _windowEvent($counter) 1 - set savedBinding [bind $w $event] - bind $w $event [list +waitForWindowEvent.signal $counter] - set afterID [after $timeout [list set _windowEvent($counter) -1]] - vwait _windowEvent($counter) - set late [expr {$_windowEvent($counter) == -1}] - bind $w $event $savedBinding - unset _windowEvent($counter) - if {$late} { - puts stderr "wait for $event event on $w timed out (> $timeout ms)" - } else { - after cancel $afterID - } -} -proc waitForWindowEvent.signal {counter} { -# Helper proc that records the triggering of a window event. - incr ::_windowEvent($counter) -} - -proc create_and_pack_frames {{w {}}} { - frame $w.f1 -bg blue -width 200 -height 200 - pack propagate $w.f1 0 - frame $w.f1.f2 -bg yellow -width 100 -height 100 - pack $w.f1.f2 $w.f1 -side bottom -anchor se - update idletasks -} - -proc setup_win_mousepointer {w} { -# Position the window and the mouse pointer as an initial state for some tests. -# The so-called "pointer window" is the $w window that will now contain the mouse pointer. - wm geometry . +700+400; # root window out of our way - must not cover windows from event-9.1* - toplevel $w - pack propagate $w 0 - wm geometry $w 300x300+100+100 - tkwait visibility $w - update; # service remaining screen drawing events (e.g. <Expose>) - set pointerWin [winfo containing [winfo pointerx $w] [winfo pointery $w]] - event generate $w <Motion> -warp 1 -x 250 -y 250 - if {($pointerWin ne $w) && ([tk windowingsystem] ne "aqua")} { - waitForWindowEvent $w <Enter> - } else { - controlPointerWarpTiming - } -} - test event-9.11 {pointer window container = parent} -setup { setup_win_mousepointer .one wm withdraw .one @@ -1018,7 +1060,9 @@ test event-9.14 {pointer window is a toplevel, tk internal destination} -setup { unset result } -result {|<Enter> NotifyNonlinearVirtual .one|<Enter> NotifyNonlinearVirtual .one.f1|<Enter> NotifyNonlinear .one.f1.f2|} -test event-9.15 {pointer window is a toplevel, destination is screen root} -setup { +test event-9.15 {pointer window is a toplevel, destination is screen root. + Due to a malfunction on macOS Sequoia and older (see bug #c494cc25c4), this test is skipped on those OS versions. +} -constraints notMacosSequoiaOrOlder -setup { setup_win_mousepointer .one; # ensure the mouse pointer is where we want it to be (the .one toplevel is not itself used in this test) # destroy .one toplevel .two @@ -1033,6 +1077,7 @@ test event-9.15 {pointer window is a toplevel, destination is screen root} -setu bind all <Leave> {append result "<Leave> %d %W|"} bind all <Enter> {append result "<Enter> %d %W|"} destroy .two + update; # Ensure that crossing events get processed. set result } -cleanup { bind all <Leave> {} @@ -1065,6 +1110,11 @@ test event-9.16 {Successive destructions (pointer window + parent), single gener unset result } -result {|<Enter> NotifyInferior .one|} +if {[tk windowingsystem] eq "aqua"} { + after 1000; # Give Apple's _windowserver some time to catch up. + update +} + test event-9.17 {Successive destructions (pointer window + parent), separate crossing events} -setup { # Tests correctness of overwriting the dead window struct in # TkPointerDeadWindow() and subsequent reading in GenerateEnterLeave(). @@ -1147,7 +1197,9 @@ test event-9.19 {Successive destructions (pointer window + ancestors including i unset result } -result {|<Enter> NotifyNonlinearVirtual .two|<Enter> NotifyNonlinearVirtual .two.f1|<Enter> NotifyNonlinear .two.f1.f2|} -test event-9.20 {Successive destructions (pointer window + ancestors including its toplevel), destination is screen root} -setup { +test event-9.20 {Successive destructions (pointer window + ancestors including its toplevel), destination is screen root. + Due to a malfunction on macOS Sequoia and older (see bug #c494cc25c4), this test is skipped on those OS versions. +} -constraints notMacosSequoiaOrOlder -setup { setup_win_mousepointer .one; # ensure the mouse pointer is where we want it to be (the .one toplevel is not itself used in this test) destroy .one toplevel .two @@ -1161,7 +1213,7 @@ test event-9.20 {Successive destructions (pointer window + ancestors including i bind all <Leave> {append result "<Leave> %d %W|"} bind all <Enter> {append result "<Enter> %d %W|"} destroy .two - update idletasks; #finish destroying .two + update; # Ensure that crossing events get processed. set result } -cleanup { bind all <Leave> {} @@ -1169,7 +1221,10 @@ test event-9.20 {Successive destructions (pointer window + ancestors including i unset result } -result {|} -# cleanup +# +# TESTFILE CLEANUP +# + # macOS sometimes has trouble deleting the test window, # causing a failure in focus.test. pause 200; @@ -1185,6 +1240,3 @@ rename create_and_pack_frames {} rename setup_win_mousepointer {} cleanupTests -return - - diff --git a/tests/filebox.test b/tests/filebox.test index cd655e9..6e5b6b6 100644 --- a/tests/filebox.test +++ b/tests/filebox.test @@ -1,59 +1,35 @@ # This file is a Tcl script to test out Tk's "tk_getOpenFile" and -# "tk_getSaveFile" commands. It is organized in the standard fashion -# for Tcl tests. +# "tk_getSaveFile" commands. # # Copyright © 1996 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -eval tcltest::configure $argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# -# Import utility procs for specific functional areas -testutils import dialog +package require tcltest 2.2; # needed in mode -singleproc 0 -test fileDialog-0.1 {GetFileName: file types: MakeFilter() fails} { - # MacOS type that is too long +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] - set res [list [catch {tk_getSaveFile -filetypes {{"foo" .foo {\0\0\0\0\0}}}} msg] $msg] - regsub -all "\0" $res {\\0} -} {1 {bad Macintosh file type "\0\0\0\0\0"}} -test fileDialog-0.2 {GetFileName: file types: MakeFilter() fails} { - # MacOS type that is too short, but looks ok in utf (4 bytes). +# Ensure a pristine initial window state +resetWindows - set x [catch {tk_getSaveFile -filetypes {{"foo" .foo {\0\0}}}} msg] - regsub -all "\0" $msg {\\0} msg - list $x $msg -} {1 {bad Macintosh file type "\0\0"}} -# The next test must actually open a file dialog window, but it does -# not require human interaction to close the dialog because the Aqua -# port of tktest automatically closes every file dialog after a short -# timeout when tests are being run. -test fileDialog-0.3 {GetFileName: file types: bad filetype} \ --constraints aqua \ --body { - # Checks for the Aqua crash reported in ticket 080a28104. - set filename [tk_getOpenFile -filetypes { - {"Invalid extension" {x.y}} - {"All files" {*}} - }] -} \ --result {} +# Import utility procs for specific functional areas +testutils import dialog set tk_strictMotif_old $tk_strictMotif -#---------------------------------------------------------------------- # -# Procedures needed by this test file +# LOCAL UTILITY PROCS # -#---------------------------------------------------------------------- - -proc ToEnterFileByKey {parent fileName fileDir} { - if {! $::dialogIsNative} { - after 100 EnterFileByKey $parent [list $fileName] [list $fileDir] - } -} proc EnterFileByKey {parent fileName fileDir} { global tk_strictMotif @@ -76,17 +52,15 @@ proc EnterFileByKey {parent fileName fileDir} { SendButtonPress $parent ok mouse } -#---------------------------------------------------------------------- +proc ToEnterFileByKey {parent fileName fileDir} { + if {! $::dialogIsNative} { + after 100 EnterFileByKey $parent [list $fileName] [list $fileDir] + } +} + # -# The test suite proper +# COMMON TEST SETUP # -#---------------------------------------------------------------------- - -if {$tcl_platform(platform) == "unix"} { - set modes "0 1" -} else { - set modes 1 -} set unknownOptionsMsg(tk_getOpenFile,notAqua) {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -multiple, -parent, -title, or -typevariable} set unknownOptionsMsg(tk_getOpenFile,aqua) {bad option "-foo": must be -command, -defaultextension, -filetypes, -initialdir, -initialfile, -message, -multiple, -parent, -title, or -typevariable} @@ -117,14 +91,56 @@ array set filters { } } +set parent . +set verylongstring [string repeat longstring: 16] + +# +# TESTS +# + +test fileDialog-0.1 {GetFileName: file types: MakeFilter() fails} { + # MacOS type that is too long + + set res [list [catch {tk_getSaveFile -filetypes {{"foo" .foo {\0\0\0\0\0}}}} msg] $msg] + regsub -all "\0" $res {\\0} +} {1 {bad Macintosh file type "\0\0\0\0\0"}} +test fileDialog-0.2 {GetFileName: file types: MakeFilter() fails} { + # MacOS type that is too short, but looks ok in utf (4 bytes). + + set x [catch {tk_getSaveFile -filetypes {{"foo" .foo {\0\0}}}} msg] + regsub -all "\0" $msg {\\0} msg + list $x $msg +} {1 {bad Macintosh file type "\0\0"}} +# The next test must actually open a file dialog window, but it does +# not require human interaction to close the dialog because the Aqua +# port of tktest automatically closes every file dialog after a short +# timeout when tests are being run. +test fileDialog-0.3 {GetFileName: file types: bad filetype} \ +-constraints aqua \ +-body { + # Checks for the Aqua crash reported in ticket 080a28104. + set filename [tk_getOpenFile -filetypes { + {"Invalid extension" {x.y}} + {"All files" {*}} + }] +} \ +-result {} + +# Test both the motif version and the "tk" version of the file dialog +# box on Unix. +# +# Note that this means that test names are unusually complex. +# +if {$tcl_platform(platform) eq "unix"} { + set modes "0 1" +} else { + set modes 1 +} foreach mode $modes { + # - # Test both the motif version and the "tk" version of the file dialog - # box on Unix. - # - # Note that this means that test names are unusually complex. + # COMMON TEST SETUP # - set addedExtensions {} if {$tcl_platform(platform) == "unix"} { set tk_strictMotif $mode @@ -170,24 +186,14 @@ foreach mode $modes { tk_getOpenFile -filetypes {Foo} } -returnCodes error -result {bad file type "Foo", should be "typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?"} - set parent . - - set verylongstring longstring: - set verylongstring $verylongstring$verylongstring - set verylongstring $verylongstring$verylongstring - set verylongstring $verylongstring$verylongstring - set verylongstring $verylongstring$verylongstring - # set verylongstring $verylongstring$verylongstring - # set verylongstring $verylongstring$verylongstring - # set verylongstring $verylongstring$verylongstring - # set verylongstring $verylongstring$verylongstring - # set verylongstring $verylongstring$verylongstring - test filebox-2.1-$mode "tk_getOpenFile command" nonUnixUserInteraction { ToPressButton $parent cancel tk_getOpenFile -title "Press Cancel ($verylongstring)" -parent $parent } "" + # + # COMMON TEST SETUP + # set fileName $tmpFile set fileDir [tcltest::temporaryDirectory] set pathName [file join $fileDir $fileName] @@ -239,14 +245,14 @@ foreach mode $modes { destroy .t2 } -test fileDialog-2.7-$mode {"tk_getOpenFile: bad extension" -body { - #ToPressButton $parent cancel - set filename [tk_getOpenFile -filetypes { - {"Invalid extension" {x.y}} - {"All files" {*}} - }] - } -result {} -} + test fileDialog-2.7-$mode {"tk_getOpenFile: bad extension" -body { + #ToPressButton $parent cancel + set filename [tk_getOpenFile -filetypes { + {"Invalid extension" {x.y}} + {"All files" {*}} + }] + } -result {} + } foreach x [lsort -integer [array names filters]] { test filebox-3.$x-$mode "tk_getOpenFile command" nonUnixUserInteraction { @@ -285,7 +291,6 @@ test fileDialog-2.7-$mode {"tk_getOpenFile: bad extension" -body { catch {tk_getSaveFile -foo 1} msg regsub -all , $msg "" options regsub \"-foo\" $options "" options - foreach option $options { if {[string index $option 0] eq "-"} { test filebox-4.2-$mode$option "tk_getSaveFile command" -body { @@ -315,6 +320,9 @@ test fileDialog-2.7-$mode {"tk_getOpenFile: bad extension" -body { tk_getSaveFile -title "Press Cancel ($verylongstring)" -parent $parent } "" + # + # COMMON TEST SETUP + # set fileName "12x 455" set fileDir [pwd] set pathName [file join [pwd] $fileName] @@ -442,11 +450,10 @@ test fileDialog-2.7-$mode {"tk_getOpenFile: bad extension" -body { } # -# CLEANUP +# TESTFILE CLEANUP # set tk_strictMotif $tk_strictMotif_old removeFile filebox.tmp testutils forget dialog cleanupTests -return diff --git a/tests/focus.test b/tests/focus.test index 4c7d3bb..c814762 100644 --- a/tests/focus.test +++ b/tests/focus.test @@ -1,21 +1,61 @@ # This file is a Tcl script to test out the "focus" command and the -# other procedures in the file tkFocus.c. It is organized in the -# standard fashion for Tcl tests. +# other procedures in the file tkFocus.c. # # Copyright © 1994-1996 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -eval tcltest::configure $argv -tcltest::loadTestedCommands -namespace import -force tcltest::test +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import child +# +# LOCAL UTILITY PROCS +# + +# focusClear -- +# +# Ensures that there is no input focus in this application. It does it by +# arranging for another application to grab the focus. The "after" and +# "update" stuff is needed to wait long enough for pending actions to get +# through the X server and possibly also the window manager. +# if {[tk windowingsystem] eq "aqua"} { - childTkInterp childInterp + proc focusClear {} { + childInterp eval { + focus -force . + set i 0 + while {[focus] != "."} { + after 100 + incr i + if {$i > 10} { + break + } + } + } + } +} else { + proc focusClear {} { + childTkProcess eval {after 200; focus -force .; update} + after 400 + update + } } proc focusSetup {} { @@ -28,6 +68,7 @@ proc focusSetup {} { } tkwait visibility .t.b4 } + proc focusSetupAlt {} { global env destroy .alt @@ -39,46 +80,27 @@ proc focusSetupAlt {} { tkwait visibility .alt.d } +# +# COMMON TEST SETUP +# -# The following procedure ensures that there is no input focus -# in this application. It does it by arranging for another -# application to grab the focus. The "after" and "update" stuff -# is needed to wait long enough for pending actions to get through -# the X server and possibly also the window manager. +# childTkProcess exit will be after 4.3 test +childTkProcess create +update if {[tk windowingsystem] eq "aqua"} { - proc focusClear {} { - childInterp eval { - focus -force . - set i 0 - while {[focus] != "."} { - after 100 - incr i - if {$i > 10} { - break - } - } - } - } -} else { - proc focusClear {} { - childTkProcess eval {after 200; focus -force .; update} - after 400 - update - } + childTkInterp childInterp } +focusSetup +if {[testConstraint altDisplay]} { + focusSetupAlt +} # Button used in some tests in the whole test file button .b -text .b -relief raised -bd 2 pack .b -# Make sure the window manager knows who has focus -catch {fixfocus} - -# childTkProcess exit will be after 4.3 test -childTkProcess create -update bind all <FocusIn> { append focusInfo "in %W %d\n" } @@ -88,11 +110,13 @@ bind all <FocusOut> { bind all <Key> { append focusInfo "press %W %K" } -focusSetup -if {[testConstraint altDisplay]} { - focusSetupAlt -} +# Make sure the window manager knows who has focus +catch {fixfocus} + +# +# TESTS +# test focus-1.1 {Tk_FocusCmd procedure} -constraints unix -body { focusClear @@ -244,8 +268,11 @@ test focus-1.25 {Tk_FocusCmd procedure} -constraints unix -body { focus -unknown } -returnCodes error -result {bad option "-unknown": must be -displayof, -force, or -lastfor} - +# +# COMMON TEST SETUP +# focusSetup + test focus-2.1 {TkFocusFilterEvent procedure} -constraints { unix nonPortable testwrapper } -body { @@ -615,6 +642,10 @@ test focus-4.4 {TkFocusDeadWindow procedure} -constraints { destroy .t.b2 focus } -result {.t} + +# +# COMMON TEST CLEANUP +# childTkProcess exit @@ -638,13 +669,16 @@ test focus-5.1 {ChangeXFocus procedure, don't take focus unless have it} -constr } -cleanup { childTkProcess exit } -result {.t {} {}} + +# +# COMMON TEST CLEANUP +# destroy .t bind all <FocusIn> {} bind all <FocusOut> {} bind all <Key> {} - - fixfocus + test focus-6.1 {miscellaneous - embedded application in same process} -constraints { unix testwrapper } -setup { @@ -800,7 +834,7 @@ test focus-8.1 {fdc0ed342d - segfault on focus -force} -body { } -result {Reached} # -# CLEANUP +# TESTFILE CLEANUP # deleteWindows @@ -809,4 +843,3 @@ cleanupTests if {[tk windowingsystem] eq "aqua"} { interp delete childInterp } -return diff --git a/tests/focusTcl.test b/tests/focusTcl.test index de3b564..fc83eb3 100644 --- a/tests/focusTcl.test +++ b/tests/focusTcl.test @@ -1,20 +1,31 @@ # This file is a Tcl script to test out the features of the script # file focus.tcl, which includes the procedures tk_focusNext and -# tk_focusPrev, among other things. This file is organized in the -# standard fashion for Tcl tests. +# tk_focusPrev, among other things. # # Copyright © 1995 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -eval tcltest::configure $argv -tcltest::loadTestedCommands -namespace import -force tcltest::test +# +# TESTFILE INITIALIZATION +# -option add *takeFocus 1 -option add *highlightThickness 2 -. configure -takefocus 1 -highlightthickness 2 +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# LOCAL UTILITY PROCS +# proc setup1 w { if {$w == "."} { @@ -48,6 +59,17 @@ proc cleanup1 w { } } +# +# COMMON TEST SETUP +# + +option add *takeFocus 1 +option add *highlightThickness 2 +. configure -takefocus 1 -highlightthickness 2 + +# +# TESTS +# test focusTcl-1.1 {tk_focusNext procedure, no children} -body { tk_focusNext . @@ -263,6 +285,9 @@ test focusTcl-3.9 {tk_focusPrev procedure, basic tree traversal} -body { cleanup1 . } -result {.} +# +# COMMON TEST SETUP +# deleteWindows setup1 . @@ -271,6 +296,7 @@ wm geom .t +0+0 toplevel .t2 wm geom .t2 -0+0 raise .t .a + test focusTcl-4.1 {tk_focusPrev procedure, toplevels} -setup { deleteWindows } -body { @@ -473,13 +499,10 @@ test focusTcl-5.11 {tkFocusOK procedure, -takefocus "", check for bindings} -bod bind Frame <Key> {} } -result {.a .b} +# +# TESTFILE CLEANUP +# . configure -takefocus 0 -highlightthickness 0 option clear - -# cleanup cleanupTests -return - - - diff --git a/tests/font.test b/tests/font.test index 034aa54..4e30d65 100644 --- a/tests/font.test +++ b/tests/font.test @@ -1,17 +1,43 @@ # This file is a Tcl script to test out Tk's "font" command -# plus the procedures in tkFont.c. It is organized in the -# standard white-box fashion for Tcl tests. +# plus the procedures in tkFont.c. # # Copyright © 1996-1998 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -eval tcltest::configure $argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# -set defaultfontlist [font names] +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# LOCAL UTILITY PROCS +# + +proc clearnondefaultfonts {} { + foreach afont [getnondefaultfonts] { + font delete $afont + } +} + +proc csetup {{str ""}} { + focus -force .t.c + .t.c dchars text 0 end + .t.c insert text 0 $str + .t.c focus text +} proc getnondefaultfonts {} { global defaultfontlist @@ -24,17 +50,29 @@ proc getnondefaultfonts {} { set nondeffonts } -proc clearnondefaultfonts {} { - foreach afont [getnondefaultfonts] { - font delete $afont - } +proc psfontname {name} { + destroy .t.c + canvas .t.c -closeenough 0 + .t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12" + pack .t.c + update + set a [.t.c itemcget text -font] + .t.c itemconfig text -text "We need text" -font $name + set post [.t.c postscript] + .t.c itemconfig text -font $a + set end [string first "findfont" $post] + incr end -2 + set post [string range $post [expr $end-70] $end] + set start [string first "gsave" $post] + destroy .t.c + return [string range $post [expr $start+7] end] } -deleteWindows -# Toplevel used (in some tests) of the whole file -toplevel .t -wm geom .t +0+0 -update idletasks +# +# COMMON TEST SETUP +# + +set defaultfontlist [font names] switch [tk windowingsystem] { x11 {set fixed "TkFixedFont"} @@ -42,15 +80,15 @@ switch [tk windowingsystem] { aqua {set fixed "monaco 9"} } +deleteWindows +# Toplevel used (in some tests) of the whole file +toplevel .t +wm geom .t +0+0 +update idletasks -# Procedure used in tests: 24.15, 26.*, 28.*, 30.*, 31.*, 32.1 -proc csetup {{str ""}} { - focus -force .t.c - .t.c dchars text 0 end - .t.c insert text 0 $str - .t.c focus text -} - +# +# TESTS +# test font-1.1 {TkFontPkgInit} -setup { catch {interp delete foo} @@ -876,25 +914,6 @@ test font-20.1 {Tk_GetFontMetrics procedure} -setup { destroy .t.w1 .t.w2 } -result {} - -# Procedure used in 21.* tests -proc psfontname {name} { - destroy .t.c - canvas .t.c -closeenough 0 - .t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12" - pack .t.c - update - set a [.t.c itemcget text -font] - .t.c itemconfig text -text "We need text" -font $name - set post [.t.c postscript] - .t.c itemconfig text -font $a - set end [string first "findfont" $post] - incr end -2 - set post [string range $post [expr $end-70] $end] - set start [string first "gsave" $post] - destroy .t.c - return [string range $post [expr $start+7] end] -} test font-21.1 {Tk_PostscriptFontName procedure: native} -constraints { unix } -body { @@ -1481,8 +1500,12 @@ test font-23.1 {Tk_UnderlineChars procedure} -setup { destroy .t.t } -result {} +# +# COMMON TEST SETUP +# +# For tests font-24.* +# -# Data used in 24.* tests destroy .t.l label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \ -text "0" -font "Courier -12" @@ -1490,6 +1513,7 @@ pack .t.l update set ax [winfo reqwidth .t.l] set ay [winfo reqheight .t.l] + test font-24.1 {Tk_ComputeTextLayout: empty string} -body { .t.l config -text "" } -result {} @@ -1608,6 +1632,10 @@ test font-24.14 {Tk_ComputeTextLayout: text ended with \n} -body { lappend x [expr {[winfo reqheight .t.l] eq [expr {$ay * 2}]}] set x } -result {1 1 1 1} + +# +# COMMON TEST CLEANUP +# destroy .t.l test font-24.15 {Tk_ComputeTextLayout: justification} -setup { @@ -1643,13 +1671,17 @@ test font-25.1 {Tk_FreeTextLayout procedure} -setup { destroy .t.f } -result {} - -# Canvas created for tests: 26.* +# +# COMMON TEST SETUP +# +# For tests font-26.* +# destroy .t.c canvas .t.c -closeenough 0 .t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12" pack .t.c update + test font-26.1 {Tk_DrawTextLayout procedure: auto-detect last char} -setup { destroy .t.f pack [label .t.f] @@ -1682,12 +1714,18 @@ test font-26.6 {Tk_DrawTextLayout: draw subset of chunk: lastChar < numChars} -b .t.c select from text 4 .t.c select to text 4 } -result {} -destroy .t.c -# Label used in 27.* tests +# +# COMMON TEST SETUP +# +# For tests font-27.* +# + +destroy .t.c destroy .t.f pack [label .t.f] update + test font-27.1 {Tk_UnderlineTextLayout procedure: no underline chosen} -body { .t.f config -text "foo" -underline {} } -result {} @@ -1698,16 +1736,20 @@ test font-27.3 {Tk_UnderlineTextLayout procedure: underline is visible} -body { .t.f config -text "000 00000" -wrap [expr $ax*7] -under 5 .t.f config -wrap 0 -underline {} } -result {} -destroy .t.f - +# +# COMMON TEST SETUP +# +# For tests font-28.* +# -# Canvas created for tests: 28.* +destroy .t.f destroy .t.c canvas .t.c -closeenough 0 .t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12" pack .t.c update + test font-28.1 {Tk_PointToChar procedure: above all lines} -body { csetup "000" .t.c index text @-1,0 @@ -1763,13 +1805,18 @@ test font-28.11 {Tk_PointToChar procedure: below all chunks} -body { csetup "000 0000000" .t.c index text @0,1000000 } -result 11 -destroy .t.c +# +# COMMON TEST SETUP +# +# For tests font-29.* +# -# Label used in 29.* tests +destroy .t.c destroy .t.f pack [label .t.f] update + test font-29.1 {Tk_CharBBox procedure: index < 0} -body { .t.f config -text "000" -underline {} } -result {} @@ -1790,16 +1837,20 @@ test font-29.6 {Tk_CharBBox procedure: bbox pegged to right edge} -body { .t.f config -text "0 0000" -wrap [expr $ax*4] -under 3 .t.f config -wrap 0 } -result {} -destroy .t.f - +# +# COMMON TEST SETUP +# +# For tests font-30.* +# -# Canvas created for tests: 30.* +destroy .t.f destroy .t.c canvas .t.c -closeenough 0 .t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12" pack .t.c update + test font-30.1 {Tk_DistanceToTextLayout procedure: loop once} -body { csetup "000\n000\n000" .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]} @@ -1862,7 +1913,12 @@ test font-30.6 {Tk_DistanceToTextLayout procedure: ignore spaces at eol} -body { } -cleanup { bind all <Enter> {} } -result {} + +# +# COMMON TEST SETUP +# .t.c itemconfig text -justify center + test font-30.7 {Tk_DistanceToTextLayout procedure: on left side} -body { csetup "0\n000" .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]} @@ -1923,7 +1979,12 @@ test font-30.12 {Tk_DistanceToTextLayout procedure: in line} -body { } -cleanup { bind all <Enter> {} } -result 3 + +# +# COMMON TEST SETUP +# .t.c itemconfig text -justify left + test font-30.13 {Tk_DistanceToTextLayout procedure: exact hit} -body { csetup "000" .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]} @@ -1934,15 +1995,18 @@ test font-30.13 {Tk_DistanceToTextLayout procedure: exact hit} -body { } -cleanup { bind all <Enter> {} } -result 1 -destroy .t.c - -# Canvas created for tests 31.* +# +# COMMON TEST SETUP +# +# For tests font-31.* +# destroy .t.c canvas .t.c -closeenough 0 .t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12" pack .t.c update + test font-31.1 {Tk_IntersectTextLayout procedure: loop once} -body { csetup "000\n000\n000" .t.c find overlapping 0 0 0 0 @@ -1980,8 +2044,11 @@ test font-31.7 {TkIntersectAngledTextLayout procedure: bug [514ff64dd0]} -body { # so it's enough to check with a small rectangle with small negative y coords. .t.c find overlapping 5 -7 7 -5 } -result 1 -destroy .t.c +# +# COMMON TEST CLEANUP +# +destroy .t.c test font-32.1 {Tk_TextLayoutToPostscript: ensure buffer doesn't overflow} -setup { destroy .t.c @@ -2564,10 +2631,8 @@ test font-47.3 {Bug 3049518 - Label} -body { unset -nocomplain ::results } -result {{1 1} {1 1} {1 1} {1 1}} -# cleanup -cleanupTests -return - - - +# +# TESTFILE CLEANUP +# +cleanupTests diff --git a/tests/fontchooser.test b/tests/fontchooser.test index 7a7c37d..4f920d1 100644 --- a/tests/fontchooser.test +++ b/tests/fontchooser.test @@ -2,16 +2,43 @@ # # Copyright © 2008 Pat Thoyts -package require tcltest 2.2 -eval tcltest::configure $argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import dialog set applyFontCmd [list set testDialogFont] -# ------------------------------------------------------------------------- +# +# LOCAL TEST CONSTRAINTS +# + +# The tk fontchooser call below autoloads fontchooser.tcl on platforms +# that don't provide a native implementation of the font selection dialog. +# This will make ::tk::fontchooser::Configure exist, and scriptImpl become true, +# indicating use of the scripted implementation of the dialog. Platforms using +# the native dialog do not define a ::tk::fontchooser::Configure proc. +catch {tk fontchooser} +testConstraint scriptImpl [llength [info proc ::tk::fontchooser::Configure]] + +# +# TESTS +# test fontchooser-1.1 {tk fontchooser: usage} -returnCodes error -body { tk fontchooser -z @@ -49,14 +76,12 @@ test fontchooser-1.9 {tk fontchooser: usage} -returnCodes error -body { tk fontchooser configure -visible 1 } -match glob -result {*} -# ------------------------------------------------------------------------- # # The remaining tests in this file are only relevant for the script # implementation. They can be tested by sourcing the script file but # the Tk tests are run with -singleproc 1 and doing this affects the # result of later attempts to test the native implementations. # -testConstraint scriptImpl [llength [info proc ::tk::fontchooser::Configure]] test fontchooser-2.0 {fontchooser -title} -constraints scriptImpl -body { testDialog launch { @@ -161,13 +186,12 @@ test fontchooser-5.1 {fontchooser multiple configure} -constraints {scriptImpl} } -result {TestTitle} # -# CLEANUP +# TESTFILE CLEANUP # unset applyFontCmd testutils forget dialog cleanupTests -return # Local Variables: # mode: tcl diff --git a/tests/frame.test b/tests/frame.test index bb68dba..c847268 100644 --- a/tests/frame.test +++ b/tests/frame.test @@ -1,20 +1,45 @@ # This file is a Tcl script to test out the "frame", "labelframe" and -# "toplevel" commands of Tk. It is organized in the standard fashion for Tcl -# tests. +# "toplevel" commands of Tk. # # Copyright © 1994 The Regents of the University of California. # Copyright © 1994-1996 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -tcltest::configure {*}$argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import colors +# +# LOCAL UTILITY PROCS +# + +# optnames -- +# +# Returns the option names out of a list of option details. +# +# Arguments: +# options - The option detail list. +proc optnames {options} { + lsort [lmap desc $options {lindex $desc 0}] +} + # uniq -- # # Returns the unique items of a list in the order they first appear. @@ -29,15 +54,9 @@ proc uniq {list} { return [dict keys $d] } -# optnames -- # -# Returns the option names out of a list of option details. +# TESTS # -# Arguments: -# options - The option detail list. -proc optnames {options} { - lsort [lmap desc $options {lindex $desc 0}] -} test frame-1.1 {frame configuration options} -setup { deleteWindows @@ -141,8 +160,12 @@ test frame-1.12 {frame configuration options} -setup { deleteWindows } -result .g +# +# COMMON TEST SETUP +# destroy .f frame .f + test frame-1.13 {frame configuration options} -body { .f configure -background #ff0000 lindex [.f configure -background] 4 @@ -266,6 +289,10 @@ test frame-1.38 {frame configuration options} -body { test frame-1.39 {frame configuration options} -body { .f configure -width badValue } -returnCodes error -result {expected screen distance but got "badValue"} + +# +# COMMON TEST CLEANUP +# destroy .f test frame-2.1 {toplevel configuration options} -setup { @@ -393,10 +420,6 @@ test frame-2.14 {toplevel configuration options} -setup { } -returnCodes error -cleanup { deleteWindows } -result {unknown or ambiguous visual name "who_knows?": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default} -set expectedScreen "" -if {[tcltest::testConstraint haveDISPLAY]} { - set expectedScreen [list -screen screen Screen {} $env(DISPLAY)] -} test frame-2.15 {toplevel configuration options} -constraints haveDISPLAY -setup { deleteWindows } -body { @@ -405,7 +428,7 @@ test frame-2.15 {toplevel configuration options} -constraints haveDISPLAY -setup .t configure -screen } -cleanup { deleteWindows -} -result $expectedScreen +} -result [expr {[tcltest::testConstraint haveDISPLAY]?[list -screen screen Screen {} $env(DISPLAY)]:""}] test frame-2.16 {toplevel configuration options} -constraints haveDISPLAY -setup { deleteWindows } -body { @@ -448,10 +471,14 @@ test frame-2.19 {toplevel configuration options} -setup { deleteWindows } -result .g +# +# COMMON TEST SETUP +# destroy .t toplevel .t -width 300 -height 150 wm geometry .t +0+0 update + test frame-2.20 {toplevel configuration options} -body { .t configure -background #ff0000 lindex [.t configure -background] 4 @@ -536,6 +563,10 @@ test frame-2.42 {toplevel configuration options} -body { test frame-2.43 {toplevel configuration options} -body { .t configure -width badValue } -returnCodes error -result {expected screen distance but got "badValue"} + +# +# COMMON TEST CLEANUP +# destroy .t test frame-3.1 {TkCreateFrame procedure} -returnCodes error -body { @@ -638,12 +669,18 @@ test frame-3.10 {TkCreateFrame procedure, -use option} -constraints { destroy .t option clear } -result {0 0 140 300} + +# +# COMMON TEST SETUP +# + # The tests below require specific display characteristics (i.e. that they are # run on a pseudocolor display of depth 8). Even so, they are non-portable: # some machines don't seem to ever run out of colors. if {[testConstraint defaultPseudocolor8]} { eatColors .t1 } + test frame-3.11 {TkCreateFrame procedure} -constraints { defaultPseudocolor8 nonPortable } -setup { @@ -790,9 +827,14 @@ test frame-3.21 {TkCreateFrame procedure} -constraints { } -cleanup { destroy .t } -result 1 + +# +# COMMON TEST CLEANUP +# if {[testConstraint defaultPseudocolor8]} { destroy .t1 } + test frame-3.22 {TkCreateFrame procedure, default dimensions} -setup { deleteWindows } -body { @@ -833,7 +875,11 @@ test frame-4.2 {TkCreateFrame procedure} -setup { deleteWindows } -result {.f 1} +# +# COMMON TEST SETUP +# frame .f -highlightcolor black + test frame-5.1 {FrameWidgetCommand procedure} -body { .f } -returnCodes error -result {wrong # args: should be ".f option ?arg ...?"} @@ -878,6 +924,10 @@ test frame-5.12 {FrameWidgetCommand procedure} -body { test frame-5.13 {FrameWidgetCommand procedure, configure option} -body { optnames [. configure] } -result {-background -backgroundimage -bd -bg -bgimg -borderwidth -class -colormap -container -cursor -height -highlightbackground -highlightcolor -highlightthickness -menu -padx -pady -relief -screen -takefocus -tile -use -visual -width} + +# +# COMMON TEST CLEANUP +# destroy .f test frame-6.1 {ConfigureFrame procedure} -setup { @@ -1176,8 +1226,14 @@ test frame-13.9 {labelframe configuration options} -setup { } -returnCodes error -cleanup { deleteWindows } -result {can't modify -container option after widget is created} + +# +# COMMON TEST SETUP +# + destroy .f labelframe .f + test frame-13.10 {labelframe configuration options} -body { .f configure -background #ff0000 lindex [.f configure -background] 4 @@ -1340,6 +1396,10 @@ test frame-13.43 {labelframe configuration options} -body { test frame-13.44 {labelframe configuration options} -body { .f configure -width badValue } -returnCodes error -result {expected screen distance but got "badValue"} + +# +# COMMON TEST CLEANUP +# destroy .f test frame-14.1 {labelframe labelwidget option} -setup { @@ -1731,7 +1791,7 @@ test frame-15.14 {TIP 262: toplevel background images} -setup { } -result {{gorp get} {gorp display 0 0 30 15} {gorp display 0 0 30 10} {gorp display 0 0 20 15} {gorp display 0 0 20 10}} # -# CLEANUP +# TESTFILE CLEANUP # deleteWindows @@ -1740,7 +1800,6 @@ apply {cmds {foreach cmd $cmds {rename $cmd {}}}} { } testutils forget colors cleanupTests -return # Local Variables: # mode: tcl diff --git a/tests/geometry.test b/tests/geometry.test index 231da90..bd423d4 100644 --- a/tests/geometry.test +++ b/tests/geometry.test @@ -1,17 +1,32 @@ # This file is a Tcl script to test the procedures in the file -# tkGeometry.c (generic support for geometry managers). It is -# organized in the standard fashion for Tcl tests. +# tkGeometry.c (generic support for geometry managers). # # Copyright © 1994 The Regents of the University of California. # Copyright © 1994 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -eval tcltest::configure $argv -tcltest::loadTestedCommands -namespace import -force tcltest::test +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] +# Ensure a pristine initial window state +resetWindows + + +# +# COMMON TEST SETUP +# wm geometry . 300x300 raise . @@ -25,6 +40,10 @@ button .b2 -text .b2 button .b3 -text .b3 button .f.f.b4 -text .b4 +# +# TESTS +# + test geometry-1.1 {Tk_ManageGeometry procedure} -setup { foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { place forget $w @@ -279,8 +298,8 @@ test geometry-4.10 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} -setup { destroy .t } -result 1 +# +# TESTFILE CLEANUP +# -# cleanup cleanupTests -return - diff --git a/tests/get.test b/tests/get.test index ce1d372..452f486 100644 --- a/tests/get.test +++ b/tests/get.test @@ -1,15 +1,30 @@ # This file is a Tcl script to test out the procedures in the file -# tkGet.c. It is organized in the standard fashion for Tcl -# white-box tests. +# tkGet.c. # # Copyright © 1998 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -eval tcltest::configure $argv -tcltest::loadTestedCommands -namespace import -force tcltest::test +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# TESTS +# test get-1.1 {Tk_GetAnchorFromObj} -setup { button .b @@ -132,7 +147,9 @@ test get-2.4 {Tk_GetJustifyFromObj - error} -setup { destroy .b } -returnCodes error -result {bad justification "stupid": must be left, right, or center} +# +# TESTFILE CLEANUP +# + # cleanup cleanupTests -return - diff --git a/tests/grab.test b/tests/grab.test index 6086ff7..847e9dd 100644 --- a/tests/grab.test +++ b/tests/grab.test @@ -1,16 +1,24 @@ # Tests for the grab command. # -# This file contains a collection of tests for one or more of the Tk -# built-in commands. Sourcing this file runs the tests and -# generates output for errors. No output means no errors were found. -# # Copyright © 1998-2000 Ajuba Solutions. # All rights reserved. -package require tcltest 2.2 -eval tcltest::configure $argv -tcltest::loadTestedCommands -namespace import -force tcltest::test +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows # The macOS test module includes the testpressbutton command to simulate a # mouse button press event by injecting events into the NSApplication @@ -19,6 +27,10 @@ namespace import -force tcltest::test # this test suite only covers the interface to the grab command (ie, # error messages, etc.) on platforms other than macOS. +# +# TESTS +# + test grab-1.1 {Tk_GrabObjCmd} -body { grab } -returnCodes error -result {wrong # args: should be "grab ?-global? window" or "grab option ?arg ...?"} @@ -211,6 +223,8 @@ test grab-6.1 {local grab on child window} -constraints { grab release .f } -result {inside outside : outside : inside outside :} -cleanupTests -return +# +# TESTFILE CLEANUP +# +cleanupTests diff --git a/tests/grid.test b/tests/grid.test index 128c244..8d2754f 100644 --- a/tests/grid.test +++ b/tests/grid.test @@ -1,19 +1,36 @@ -# This file is a Tcl script to test out the *NEW* "grid" command of Tk. It is -# (almost) organized in the standard fashion for Tcl tests. +# This file is a Tcl script to test out the *NEW* "grid" command of Tk. # # Copyright © 1996 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -eval tcltest::configure $argv -tcltest::loadTestedCommands -namespace import -force tcltest::test +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] -# helper routine to return "." to a sane state after a test. -# The variable GRID_VERBOSE can be used to "look" at the result of one or all -# of the tests +# Ensure a pristine initial window state +resetWindows +# +# LOCAL UTILITY PROCS +# + +# grid_reset -- +# +# Helper routine to return "." to a sane state after a test. +# The variable GRID_VERBOSE can be used to "look" at the result of one or all +# of the tests +# proc grid_reset {{test ?} {top .}} { global GRID_VERBOSE if {[info exists GRID_VERBOSE]} { @@ -37,9 +54,17 @@ proc grid_reset {{test ?} {top .}} { update } +# +# COMMON TEST SETUP +# + grid_reset 0.0 wm geometry . {} - + +# +# TESTS +# + test grid-1.1 {basic argument checking} -body { grid } -returnCodes error -result {wrong # args: should be "grid option arg ?arg ...?"} @@ -247,7 +272,7 @@ test grid-4.4 {forget} -body { grid .c -row 0 -column 0 grid info .c } -cleanup { - grid_reset 4.3.1 + grid_reset 4.4 } -result {-in . -column 0 -row 0 -columnspan 1 -rowspan 1 -ipadx 0 -ipady 0 -padx 0 -pady 0 -sticky {}} test grid-4.5 {forget, calling Tk_UnmaintainGeometry} -body { frame .f -bd 2 -relief raised @@ -261,7 +286,7 @@ test grid-4.5 {forget, calling Tk_UnmaintainGeometry} -body { update lappend x [winfo ismapped .f2] } -cleanup { - grid_reset 4.4 + grid_reset 4.5 } -result {1 0} test grid-5.1 {info: basic argument checking} -body { @@ -793,17 +818,17 @@ test grid-10.32 {column/row configure} -body { destroy .f return $res } -cleanup { - grid_reset 10.35 + grid_reset 10.32 } -result {} test grid-10.33 {column/row configure} -body { grid columnconfigure . all } -cleanup { - grid_reset 10.36 + grid_reset 10.33 } -returnCodes error -result {expected integer but got "all" (when retrieving options only integer indices are allowed)} test grid-10.34 {column/row configure} -body { grid columnconfigure . 100000 } -cleanup { - grid_reset 10.37 + grid_reset 10.34 } -result {-minsize 0 -pad 0 -uniform {} -weight 0} test grid-10.35 {column/row configure} -body { # This is a test for bug 1423666 where a column >= 10000 caused @@ -818,7 +843,10 @@ test grid-10.35 {column/row configure} -body { lappend res [catch {grid .f -column 9998 -columnspan 2} msg] $msg ; update lappend res [catch {grid .f -row 9998 -rowspan 2} msg] $msg ; update return $res -} -cleanup {destroy .f} -result [lrange { +} -cleanup { + destroy .f + grid_reset 10.35 +} -result [lrange { 1 {column out of bounds} 1 {row out of bounds} 1 {column out of bounds} @@ -826,7 +854,6 @@ test grid-10.35 {column/row configure} -body { 1 {column out of bounds} 1 {row out of bounds} } 0 end] -grid_reset 10.38 test grid-10.36 {column/row configure} -body { # Additional tests for row/column overflow frame .f @@ -841,13 +868,15 @@ test grid-10.36 {column/row configure} -body { lappend res [catch {eval grid [string repeat " x " 9999] .f} msg] $msg update return $res -} -cleanup {destroy .f .g} -result [lrange { +} -cleanup { + destroy .f .g + grid_reset 10.36 +} -result [lrange { 1 {row out of bounds} 1 {row out of bounds} 1 {column out of bounds} 1 {column out of bounds} } 0 end] -grid_reset 10.39 # auto-placement tests test grid-11.1 {default widget placement} -body { @@ -1146,33 +1175,33 @@ test grid-13.2 {-in} -body { [catch {grid .f -in .f} err] $err \ [winfo manager .f] } -cleanup { - grid_reset 13.1.1 + grid_reset 13.2 } -result {{} 1 {window can't be managed in itself} {}} test grid-13.3 {-in} -body { frame .f -bg red grid .f -in .bad } -cleanup { - grid_reset 13.2 + grid_reset 13.3 } -returnCodes error -result {bad window path name ".bad"} test grid-13.4 {-in} -body { frame .f -bg red toplevel .top grid .f -in .top } -cleanup { - grid_reset 13.3 + grid_reset 13.4 + destroy .top } -returnCodes error -result {can't put ".f" inside ".top"} -destroy .top test grid-13.5 {-ipadx} -body { frame .f -width 20 -height 20 -highlightthickness 0 -bg red grid .f -ipadx x } -cleanup { - grid_reset 13.4 + grid_reset 13.5 } -returnCodes error -result {bad ipadx value "x": must be positive screen distance} test grid-13.6 {-ipadx} -body { frame .f -width 20 -height 20 -highlightthickness 0 -bg red grid .f -ipadx {5 5} } -cleanup { - grid_reset 13.4.1 + grid_reset 13.6 } -returnCodes error -result {bad ipadx value "5 5": must be positive screen distance} test grid-13.7 {-ipadx} -body { frame .f -width 200 -height 100 -highlightthickness 0 -bg red @@ -1183,19 +1212,19 @@ test grid-13.7 {-ipadx} -body { update list $a [winfo width .f] } -cleanup { - grid_reset 13.5 + grid_reset 13.7 } -result {200 202} test grid-13.8 {-ipady} -body { frame .f -width 20 -height 20 -highlightthickness 0 -bg red grid .f -ipady x } -cleanup { - grid_reset 13.6 + grid_reset 13.8 } -returnCodes error -result {bad ipady value "x": must be positive screen distance} test grid-13.9 {-ipady} -body { frame .f -width 20 -height 20 -highlightthickness 0 -bg red grid .f -ipady {5 5} } -cleanup { - grid_reset 13.6.1 + grid_reset 13.9 } -returnCodes error -result {bad ipady value "5 5": must be positive screen distance} test grid-13.10 {-ipady} -body { frame .f -width 200 -height 100 -highlightthickness 0 -bg red @@ -1206,19 +1235,19 @@ test grid-13.10 {-ipady} -body { update list $a [winfo height .f] } -cleanup { - grid_reset 13.7 + grid_reset 13.10 } -result {100 102} test grid-13.11 {-padx} -body { frame .f -width 20 -height 20 -highlightthickness 0 -bg red grid .f -padx x } -cleanup { - grid_reset 13.8 + grid_reset 13.11 } -returnCodes error -result {bad pad value "x": must be positive screen distance} test grid-13.12 {-padx} -body { frame .f -width 20 -height 20 -highlightthickness 0 -bg red grid .f -padx {10 x} } -cleanup { - grid_reset 13.8.1 + grid_reset 13.12 } -returnCodes error -result {bad 2nd pad value "x": must be positive screen distance} test grid-13.13 {-padx} -body { frame .f -width 200 -height 100 -highlightthickness 0 -bg red @@ -1229,7 +1258,7 @@ test grid-13.13 {-padx} -body { update list $a "[winfo width .f] [winfo width .] [winfo x .f]" } -cleanup { - grid_reset 13.9 + grid_reset 13.13 } -result {{200 200} {200 202 1}} test grid-13.14 {-padx} -body { frame .f -width 200 -height 100 -highlightthickness 0 -bg red @@ -1240,19 +1269,19 @@ test grid-13.14 {-padx} -body { update list $a "[winfo width .f] [winfo width .] [winfo x .f]" } -cleanup { - grid_reset 13.9.1 + grid_reset 13.14 } -result {{200 200} {200 215 10}} test grid-13.15 {-pady} -body { frame .f -width 20 -height 20 -highlightthickness 0 -bg red grid .f -pady x } -cleanup { - grid_reset 13.10 + grid_reset 13.15 } -returnCodes error -result {bad pad value "x": must be positive screen distance} test grid-13.16 {-pady} -body { frame .f -width 20 -height 20 -highlightthickness 0 -bg red grid .f -pady {10 x} } -cleanup { - grid_reset 13.10.1 + grid_reset 13.16 } -returnCodes error -result {bad 2nd pad value "x": must be positive screen distance} test grid-13.17 {-pady} -body { frame .f -width 200 -height 100 -highlightthickness 0 -bg red @@ -1263,7 +1292,7 @@ test grid-13.17 {-pady} -body { update list $a "[winfo height .f] [winfo height .] [winfo y .f]" } -cleanup { - grid_reset 13.11 + grid_reset 13.17 } -result {{100 100} {100 102 1}} test grid-13.18 {-pady} -body { frame .f -width 200 -height 100 -highlightthickness 0 -bg red @@ -1274,7 +1303,7 @@ test grid-13.18 {-pady} -body { update list $a "[winfo height .f] [winfo height .] [winfo y .f]" } -cleanup { - grid_reset 13.11.1 + grid_reset 13.18 } -result {{100 100} {100 120 4}} test grid-13.19 {-ipad x and y} -body { frame .f -width 20 -height 20 -highlightthickness 0 -bg red @@ -1293,7 +1322,7 @@ test grid-13.19 {-ipad x and y} -body { } return $a } -cleanup { - grid_reset 13.12 + grid_reset 13.19 } -result { 0,0:,65,40,20,20 0,5:,65,35,20,30 5,0:,60,40,30,20 5,5:,60,35,30,30} test grid-13.20 {reparenting} -body { frame .1 @@ -1310,7 +1339,7 @@ test grid-13.20 {reparenting} -body { unset info return $a } -cleanup { - grid_reset 13.13 + grid_reset 13.20 } -result {.b,,.1 ,.b,.2} test grid-14.1 {structure notify} -body { @@ -1969,33 +1998,36 @@ test grid-21.7 {anchor} -body { test grid-22.1 {remove: basic argument checking} { list [catch {grid remove foo} msg] $msg } {1 {bad window path name "foo"}} -test grid-22.2 {remove} { +test grid-22.2 {remove} -body { button .c grid [button .b] set a [grid content .] grid remove .b .c lappend a [grid content .] return $a -} {.b {}} -grid_reset 22.2 -test grid-22.3 {remove} { +} -cleanup { + grid_reset 22.2 +} -result {.b {}} +test grid-22.3 {remove} -body { button .c grid .c -row 2 -column 2 -rowspan 2 -columnspan 2 -padx 3 -pady 4 -sticky ns grid remove .c grid .c -row 0 -column 0 grid info .c -} {-in . -column 0 -row 0 -columnspan 2 -rowspan 2 -ipadx 0 -ipady 0 -padx 3 -pady 4 -sticky ns} -grid_reset 22.3 -test grid-22.3.1 {remove} { +} -cleanup { + grid_reset 22.3 +} -result {-in . -column 0 -row 0 -columnspan 2 -rowspan 2 -ipadx 0 -ipady 0 -padx 3 -pady 4 -sticky ns} +test grid-22.3.1 {remove} -body { frame .a button .c grid .c -in .a -row 2 -column 2 -rowspan 2 -columnspan 2 -padx {3 5} -pady {4 7} -sticky ns grid remove .c grid .c -row 0 -column 0 grid info .c -} {-in .a -column 0 -row 0 -columnspan 2 -rowspan 2 -ipadx 0 -ipady 0 -padx {3 5} -pady {4 7} -sticky ns} -grid_reset 22.3.1 -test grid-22.4 {remove, calling Tk_UnmaintainGeometry} { +} -cleanup { + grid_reset 22.3.1 +} -result {-in .a -column 0 -row 0 -columnspan 2 -rowspan 2 -ipadx 0 -ipady 0 -padx {3 5} -pady {4 7} -sticky ns} +test grid-22.4 {remove, calling Tk_UnmaintainGeometry} -body { frame .f -bd 2 -relief raised place .f -x 10 -y 20 -width 200 -height 100 frame .f2 -width 50 -height 30 -bg red @@ -2006,9 +2038,10 @@ test grid-22.4 {remove, calling Tk_UnmaintainGeometry} { place .f -x 30 update lappend x [winfo ismapped .f2] -} {1 0} -grid_reset 22.4 -test grid-22.5 {remove} { +} -cleanup { + grid_reset 22.4 +} -result {1 0} +test grid-22.5 {remove} -body { frame .a button .c grid .c -in .a -row 2 -column 2 -rowspan 2 -columnspan 2 -padx {3 5} -pady {4 7} -sticky ns @@ -2018,11 +2051,12 @@ test grid-22.5 {remove} { destroy .a grid .c -row 0 -column 0 grid info .c -} {-in . -column 0 -row 0 -columnspan 2 -rowspan 2 -ipadx 0 -ipady 0 -padx {3 5} -pady {4 7} -sticky ns} -grid_reset 22.5 +} -cleanup { + grid_reset 22.5 +} -result {-in . -column 0 -row 0 -columnspan 2 -rowspan 2 -ipadx 0 -ipady 0 -padx {3 5} -pady {4 7} -sticky ns} test grid-23 {grid configure -in leaked from previous container window - bug - 6aea69fccbb266b7f0437686379fbe5b55442958} { + 6aea69fccbb266b7f0437686379fbe5b55442958} -body { frame .f frame .g pack .f .g @@ -2037,8 +2071,9 @@ test grid-23 {grid configure -in leaked from previous container window - bug pack forget .f update winfo ismapped .t ; # must return 1 -} 1 -grid_reset 23 +} -cleanup { + grid_reset 23 +} -result 1 test grid-24.1 {<<NoManagedChild>> fires on last grid forget} -setup { global A @@ -2154,10 +2189,12 @@ test grid-24.8 {<<NoManagedChild>> does not fire on last grid forget if propagat bind . <<NoManagedChild>> {} grid_reset 24.8 } -result 0 - -# cleanup + +# +# TESTFILE CLEANUP +# + cleanupTests -return # Local Variables: # mode: tcl diff --git a/tests/image.test b/tests/image.test index e3cd268..2bb2ed6 100644 --- a/tests/image.test +++ b/tests/image.test @@ -1,27 +1,45 @@ # This file is a Tcl script to test out the "image" command and the -# other procedures in the file tkImage.c. It is organized in the -# standard fashion for Tcl tests. +# other procedures in the file tkImage.c. # # Copyright © 1994 The Regents of the University of California. # Copyright © 1994 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -eval tcltest::configure $argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import image imageInit +# +# COMMON TEST SETUP +# + # Canvas used in some tests in the whole file canvas .c -highlightthickness 2 pack .c update +# +# TESTS +# test image-1.1 {Tk_ImageCmd procedure, "create" option} -body { image @@ -589,14 +607,13 @@ test image-15.1 {deleting image does not make widgets forget about it} -setup { } -result {10 10 20 20 foo {} {10 10 30 30} foo} # -# CLEANUP +# TESTFILE CLEANUP # destroy .c imageFinish testutils forget image cleanupTests -return # Local variables: # mode: tcl diff --git a/tests/imgBmap.test b/tests/imgBmap.test index 95cfab3..05bb060 100644 --- a/tests/imgBmap.test +++ b/tests/imgBmap.test @@ -1,22 +1,46 @@ # This file is a Tcl script to test out images of type "bitmap" (i.e., -# the procedures in the file tkImgBmap.c). It is organized in the -# standard fashion for Tcl tests. +# the procedures in the file tkImgBmap.c). # # Copyright © 1994 The Regents of the University of California. # Copyright © 1994-1995 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -eval tcltest::configure $argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import image imageInit +# +# LOCAL UTILITY PROCS +# + +proc bgerror msg { + global errMsg + set errMsg $msg +} + +# +# COMMON TEST SETUP +# + set data1 {#define foo_width 16 #define foo_height 16 #define foo_x_hot 3 @@ -38,16 +62,10 @@ makeFile $data1 foo.bm makeFile $data2 foo2.bm imageCleanup -#canvas .c -#pack .c -#update -#image create bitmap i1 -#.c create image 200 100 -image i1 -update -proc bgerror msg { - global errMsg - set errMsg $msg -} + +# +# TESTS +# test imageBmap-1.1 {options for bitmap images} -body { image create bitmap i1 -background #123456 @@ -120,8 +138,11 @@ test imageBmap-1.12 {options for bitmap images} -body { list [catch {image create bitmap i1 -data $data1 -maskfile bogus} msg] \ [string tolower $msg] } -result {1 {couldn't read bitmap file "bogus": no such file or directory}} -rename bgerror {} +# +# COMMON TEST CLEANUP +# +rename bgerror {} test imageBmap-2.1 {ImgBmapCreate procedure} -setup { imageCleanup @@ -341,17 +362,24 @@ test imageBmap-6.1 {NextBitmapWord procedure} -setup {imageCleanup} -body { test imageBmap-6.2 {NextBitmapWord procedure} -setup {imageCleanup} -body { makeFile {1234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890} foo3.bm image create bitmap i1 -file foo3.bm +} -cleanup { + removeFile foo3.bm } -returnCodes error -result {format error in bitmap data} test imageBmap-6.3 {NextBitmapWord procedure} -setup {imageCleanup} -body { makeFile { } foo3.bm image create bitmap i1 -file foo3.bm +} -cleanup { + removeFile foo3.bm } -returnCodes error -result {format error in bitmap data} -removeFile foo3.bm - +# +# COMMON TEST SETUP +# +# For tests imageBmap-7.* +# imageCleanup -# Image used in 7.* tests image create bitmap i1 + test imageBmap-7.1 {ImgBmapCmd procedure} -body { i1 } -returnCodes error -result {wrong # args: should be "i1 option ?arg ...?"} @@ -384,7 +412,10 @@ test imageBmap-7.9 {ImgBmapCmd procedure} -body { test imageBmap-7.10 {ImgBmapCmd procedure} -body { i1 gorp } -returnCodes error -result {bad option "gorp": must be cget or configure} -# Clean it up after use!! + +# +# COMMON TEST CLEANUP +# imageCleanup test imageBmap-8.1 {ImgBmapGet/Free procedures, shared instances} -setup { @@ -443,11 +474,14 @@ test imageBmap-9.2 {ImgBmapDisplay procedure, nothing to display} -setup { image delete i1 destroy .c } -result {} + +# +# COMMON TEST CLEANUP +# if {[info exists bgerror]} { rename bgerror {} } - test imageBmap-10.1 {ImgBmapFree procedure, resource freeing} -setup { destroy .c pack [canvas .c] @@ -511,7 +545,7 @@ test imageBmap-12.1 {ImgBmapCmdDeletedProc procedure} -body { } -result {0 1 {invalid command name "i2"}} # -# CLEANUP +# TESTFILE CLEANUP # removeFile foo.bm @@ -519,7 +553,6 @@ removeFile foo2.bm imageFinish testutils forget image cleanupTests -return # Local Variables: # mode: tcl diff --git a/tests/imgListFormat.test b/tests/imgListFormat.test index cc43dff..6453324 100644 --- a/tests/imgListFormat.test +++ b/tests/imgListFormat.test @@ -1,27 +1,43 @@ # This file is a Tcl script to test out the default image data format # ("list format") implementend in the file tkImgListFormat.c. -# It is organized in the standard fashion for Tcl tests. # # Copyright © 2017 Simon Bachmann # All rights reserved. # # Author: Simon Bachmann (simonbachmann@bluewin.ch) -package require tcltest 2.2 -namespace import ::tcltest::* -tcltest::configure {*}$argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import image imageInit +# +# TEST INITIALIZATION +# + set teapotPhotoFile [file join [file dirname [info script]] teapot.ppm] set transpTeapotPhotoFile [file join [file dirname [info script]] teapotTransparent.png] -# --------------------------------------------------------------------- - +# +# TESTS +# test imgListFormat-1.1 {ParseFormatOptions: default values} -setup { image create photo photo1 @@ -637,10 +653,9 @@ test imgListFormat-9.14 {ParseColorAsStandard: suffix not allowed #2} -setup { } -returnCodes error -result {invalid color name "#1111#1"} # -# CLEANUP +# TESTFILE CLEANUP # imageFinish testutils forget image cleanupTests -return diff --git a/tests/imgPNG.test b/tests/imgPNG.test index ce39b06..85ac3c4 100644 --- a/tests/imgPNG.test +++ b/tests/imgPNG.test @@ -1,6 +1,5 @@ # This file is a Tcl script to test out the code in tkImgFmtPNG.c, which reads -# and write PNG-format image files for photo widgets. The files is organized -# in the standard fashion for Tcl tests. +# and write PNG-format image files for photo widgets. # # Copyright © 1994-1997 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. @@ -8,16 +7,32 @@ # Copyright © 2008 Donal K. Fellows # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -eval tcltest::configure $argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import image imageInit +# +# COMMON TEST SETUP +# + namespace eval png { variable encoded # Key names are from the names of the source images, which come from @@ -1066,6 +1081,11 @@ FklEQVR4nGP4+vXrP11lJgYGhj9xSQAzOwXsETZ69QAAAABJRU5ErkJggg==" } # $encoded(basn0g08), $encoded(basn2c08), $encoded(basn3p08), $encoded(basn6a08) + +# +# TESTS +# + test imgPNG-1.1 {reading basic images; grayscale} -setup { catch {rename foo ""} } -body { @@ -1130,7 +1150,7 @@ test imgPNG-4.1 {data image with metadata} -body { } -result {DPI 99.9998 aspect 2.0} test imgPNG-4.2 {file image with metadata} -setup { - set path [file join [configure -tmpdir] test.png] + set path [file join [tcltest::configure -tmpdir] test.png] set h [open $path "WRONLY BINARY CREAT"] puts -nonewline $h [binary decode base64 $encoded(dpi100aspect2)] close $h @@ -1155,7 +1175,7 @@ test imgPNG-4.3 {data output with metadata} -setup { test imgPNG-4.4 {file output with metadata} -setup { image create photo i1 -data $encoded(dpi100aspect2) - set path [file join [configure -tmpdir] test.png] + set path [file join [tcltest::configure -tmpdir] test.png] } -body { i1 write $path -format png image delete i1 @@ -1169,14 +1189,13 @@ test imgPNG-4.4 {file output with metadata} -setup { } # -# CLEANUP +# TESTFILE CLEANUP # namespace delete png imageFinish testutils forget image cleanupTests -return # Local Variables: # mode: tcl diff --git a/tests/imgPPM.test b/tests/imgPPM.test index 907098f..85d70e1 100644 --- a/tests/imgPPM.test +++ b/tests/imgPPM.test @@ -1,21 +1,36 @@ # This file is a Tcl script to test out the code in tkImgFmtPPM.c, # which reads and write PPM-format image files for photo widgets. -# The files is organized in the standard fashion for Tcl tests. # # Copyright © 1994-1997 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -eval tcltest::configure $argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import image imageInit +# +# LOCAL UTILITY PROCS +# + # Note that we do not use [tcltest::makeFile] because it is # only suitable for text files proc put {file data} { @@ -25,6 +40,10 @@ proc put {file data} { close $f } +# +# TESTS +# + test imgPPM-1.1 {FileReadPPM procedure} -body { put test.ppm "P6\n0 256\n255\nabcdef" image create photo p1 -file test.ppm @@ -230,14 +249,13 @@ test imgPPM-5.9 {StringReadPPM procedure} -setup { } -result {5 4} # -# CLEANUP +# TESTFILE CLEANUP # imageFinish catch {file delete test.ppm} testutils forget image cleanupTests -return # Local Variables: # mode: tcl diff --git a/tests/imgPhoto.test b/tests/imgPhoto.test index d01ca1f..3fa4f4e 100644 --- a/tests/imgPhoto.test +++ b/tests/imgPhoto.test @@ -1,6 +1,5 @@ # This file is a Tcl script to test out the "photo" image type and the other -# procedures in the file tkImgPhoto.c. It is organized in the standard fashion -# for Tcl tests. +# procedures in the file tkImgPhoto.c. # # Copyright © 1994 The Australian National University # Copyright © 1994-1997 Sun Microsystems, Inc. @@ -10,8 +9,9 @@ # # Author: Paul Mackerras (paulus@cs.anu.edu.au) +# NOTES # -# This file is somewhat caothic: the order of the tests does not +# This file is somewhat chaotic: the order of the tests does not # really follow the order of the corresponding functions in # tkImgPhoto.c. Probably, because early versions had only a few tests # and over time test cases were added in bits and pieces. @@ -22,8 +22,6 @@ # tests for each of the functions in tkImgPhoto.c. The function are # listed in the order as they appear in the source file. # - -# # Function name Tests for function #-------------------------------------------------------------------------- # PhotoFormatThreadExitProc no tests @@ -55,12 +53,9 @@ # Tk_PhotoSetMetadata: imgPhoto-22.* #-------------------------------------------------------------------------- # - # # Some tests are not specific to a function in tkImgPhoto.c. They are: # - -# # Test name(s) Description #-------------------------------------------------------------------------- # imgPhoto-5.* Do not really belong to this file. ImgPhotoGet and @@ -72,29 +67,31 @@ # imgPhoto-13.* Tests for separation in different interpreters # imgPhoto-14.* Test GIF format. Would belong to imgGIF.test # - which does not exist. + # +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 -package require tcltest 2.2 -namespace import ::tcltest::* -tcltest::configure {*}$argv -tcltest::loadTestedCommands +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import image # -# Used for imgPhoto-4.65 - imgPhoto-4.73 +# LOCAL UTILITY PROCS # -proc foreachPixel {img xVar yVar script} { - upvar 1 $xVar x $yVar y - set width [image width $img] - set height [image height $img] - for {set x 0} {$x<$width} {incr x} { - for {set y 0} {$y<$height} {incr y} { - uplevel 1 $script - } - } -} + proc checkImgTrans {img} { set result {} foreachPixel $img x y { @@ -104,6 +101,7 @@ proc checkImgTrans {img} { } return $result } + proc checkImgTransLoop {img script1 script2} { set result {} foreachPixel $img x y { @@ -117,6 +115,24 @@ proc checkImgTransLoop {img script1 script2} { return $result } +# +# Used for imgPhoto-4.65 - imgPhoto-4.73 +# +proc foreachPixel {img xVar yVar script} { + upvar 1 $xVar x $yVar y + set width [image width $img] + set height [image height $img] + for {set x 0} {$x<$width} {incr x} { + for {set y 0} {$y<$height} {incr y} { + uplevel 1 $script + } + } +} + +# +# COMMON TEST SETUP +# + imageInit set README [makeFile { README -- Tk test suite design document. @@ -125,6 +141,9 @@ set README [makeFile { set teapotPhotoFile [file join [file dirname [info script]] teapot.ppm] set transpTeapotPhotoFile [file join [file dirname [info script]] teapotTransparent.png] +# +# TESTS +# test imgPhoto-1.1 {options for photo images} -body { image create photo photo1 -width 79 -height 83 @@ -2098,7 +2117,11 @@ test imgPhoto-22.3 {option -metadata, clear value} -setup { catch {image delete photo1} } -result {} -# 23.x GIF images with metadata +# +# COMMON TEST SETUP +# +# For tests imgPhoto-23.* : GIF images with metadata +# # The following gif core data is used by the following data. # N.B. this is the same image as test imgPhoto-18.10 @@ -2134,7 +2157,7 @@ test imgPhoto-23.2 {GIF file comment before image data (-file)} -setup { append data "\x21\xfe\x04" "ABCD" "\x0" # Trailer append data $::gifdata $::gifend - set path [file join [configure -tmpdir] test.gif] + set path [file join [tcltest::configure -tmpdir] test.gif] set h [open $path "WRONLY BINARY CREAT"] puts -nonewline $h $data close $h @@ -2167,7 +2190,7 @@ test imgPhoto-23.4 {GIF comment after image data (-file)} -setup { append data "\x21\xfe\x04" "ABCD" "\x0" # Trailer append data $::gifend - set path [file join [configure -tmpdir] test.gif] + set path [file join [tcltest::configure -tmpdir] test.gif] set h [open $path "WRONLY BINARY CREAT"] puts $h $data close $h @@ -2204,7 +2227,7 @@ test imgPhoto-23.6 {Two GIF comment blocks (-file)} -setup { append data "\x21\xfe\x04" "ABCD" "\x0" # Trailer append data $::gifend - set path [file join [configure -tmpdir] test.gif] + set path [file join [tcltest::configure -tmpdir] test.gif] set h [open $path "WRONLY BINARY CREAT"] puts $h $data close $h @@ -2242,7 +2265,7 @@ test imgPhoto-23.8 {create: test if shared metadata object is not preserved\ # Trailer append data $::gifdata $::gifend - set path [file join [configure -tmpdir] test.gif] + set path [file join [tcltest::configure -tmpdir] test.gif] set h [open $path "WRONLY BINARY CREAT"] puts $h $data close $h @@ -2283,7 +2306,7 @@ test imgPhoto-23.10 {configure: test if shared metadata object is not preserved\ # Trailer append data $::gifdata $::gifend - set path [file join [configure -tmpdir] test.gif] + set path [file join [tcltest::configure -tmpdir] test.gif] set h [open $path "WRONLY BINARY CREAT"] puts $h $data close $h @@ -2325,7 +2348,7 @@ test imgPhoto-23.12 {configure: test if shared metadata object is not preserved\ # Trailer append data $::gifdata $::gifend - set path [file join [configure -tmpdir] test.gif] + set path [file join [tcltest::configure -tmpdir] test.gif] set h [open $path "WRONLY BINARY CREAT"] puts $h $data close $h @@ -2368,7 +2391,7 @@ test imgPhoto-23.14 {configure: test if shared metadata object is not preserved\ # Trailer append data $::gifdata $::gifend - set path [file join [configure -tmpdir] test.gif] + set path [file join [tcltest::configure -tmpdir] test.gif] set h [open $path "WRONLY BINARY CREAT"] puts $h $data close $h @@ -2407,7 +2430,7 @@ test imgPhoto-23.16 {output data with comment (from -metadata property)}\ test imgPhoto-23.17 {output file with comment (from -metadata property)}\ -setup { set data $::gifstart$::gifdata$::gifend - set path [file join [configure -tmpdir] test.gif] + set path [file join [tcltest::configure -tmpdir] test.gif] } -body { image create photo gif1 -data $data gif1 configure -metadata [dict create comment ABCD] @@ -2438,7 +2461,7 @@ test imgPhoto-23.18 {configure: empty metadata parameter overwrites image metada test imgPhoto-23.19 {write: empty metadata parameter overwrites image metadata} -setup { image create photo gif1 -data $::gifstart$::gifdata$::gifend\ -metadata {comment bar} - set path [file join [configure -tmpdir] test.gif] + set path [file join [tcltest::configure -tmpdir] test.gif] } -body { gif1 write $path -format gif -metadata {} image delete gif1 @@ -2603,10 +2626,14 @@ test imgPhoto-23.29 {GIF multiple options metadata in -index 1} -setup { catch {image delete gif1} } -result {{update region} {0 0 16 16} {delay time} 4096 {disposal method} {do not dispose} {user interaction} 1} +# +# COMMON TEST SETUP +# +# For tests imgPhoto-24.* +# unset -nocomplain gifstart gifdata gifend - - set earthPhotoFile [file join [file dirname [info script]] earth.gif] + test imgPhoto-24.1 {Read GIF file with -from option - Bug [1576528]} -body { set earthPhotoFile [file join [file dirname [info script]] earth.gif] image create photo gif1 @@ -2655,9 +2682,15 @@ test imgPhoto-24.6 {Read GIF file with -from option, read large region from smal } -cleanup { catch {image delete gif1} } -result {{coordinates for -from option extend outside source image} 0 0} -unset earthPhotoFile +# +# COMMON TEST SETUP +# +# For tests imgPhoto-25.* +# +unset earthPhotoFile set ousterPhotoFile [file join [file dirname [info script]] ouster.png] + test imgPhoto-25.1 {Read PNG file with -from option - Bug [1576528]} -body { image create photo png1 png1 read $ousterPhotoFile -from 102 62 135 97 @@ -2701,12 +2734,12 @@ test imgPhoto-25.6 {Read PNG file with -from option, read large region from smal } -cleanup { catch {image delete png1} } -result {{coordinates for -from option extend outside source image} 0 0} -unset ousterPhotoFile # -# CLEANUP +# TESTFILE CLEANUP # +unset ousterPhotoFile catch {rename foreachPixel {}} catch {rename checkImgTrans {}} catch {rename checkImgTransLoop {}} @@ -2715,7 +2748,6 @@ removeFile README-imgPhoto testutils forget image cleanupTests -return # Local variables: # mode: tcl diff --git a/tests/imgSVGnano.test b/tests/imgSVGnano.test index 222222e..d0ba807 100644 --- a/tests/imgSVGnano.test +++ b/tests/imgSVGnano.test @@ -1,14 +1,25 @@ # This file is a Tcl script to test out the code in tkImgSVGnano.c, which reads -# and write SVG-format image files for photo widgets. The files is organized -# in the standard fashion for Tcl tests. +# and write SVG-format image files for photo widgets. # # Copyright © 2018 Rene Zaumseil # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -eval tcltest::configure $argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import image @@ -17,6 +28,10 @@ imageInit namespace eval svgnano { + # + # COMMON TEST SETUP + # + variable data set data(plus) {\ @@ -40,6 +55,9 @@ namespace eval svgnano { tcltest::makeFile $data(bad) bad.svg set data(badFilePath) [file join [tcltest::configure -tmpdir] bad.svg] +# +# TESTS +# test imgSVGnano-1.1 {reading simple image} -setup { catch {rename foo ""} @@ -252,20 +270,22 @@ test imgSVGnano-5.2 {bug d6e9b4db40 - "<svg" and ">" must be present} -body { </g></svg>} } -returnCodes error -result {couldn't recognize image data} + # + # COMMON TEST CLEANUP + # tcltest::removeFile plus.svg tcltest::removeFile bad.svg };# end of namespace svgnano # -# CLEANUP +# TESTFILE CLEANUP # namespace delete svgnano imageFinish testutils forget image cleanupTests -return # Local Variables: # mode: tcl diff --git a/tests/listbox.test b/tests/listbox.test index 5a3bf00..4211647 100644 --- a/tests/listbox.test +++ b/tests/listbox.test @@ -1,44 +1,42 @@ # This file is a Tcl script to test out the "listbox" command -# of Tk. It is organized in the standard fashion for Tcl tests. +# of Tk. # # Copyright © 1993-1994 The Regents of the University of California. # Copyright © 1994-1997 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -eval tcltest::configure $argv -tcltest::loadTestedCommands -namespace import -force tcltest::test +# +# TESTFILE INITIALIZATION +# -set fixed {Courier -12} +package require tcltest 2.2; # needed in mode -singleproc 0 -proc record {name args} { - global log - lappend log [format {%s %.6g %.6g} $name {*}$args] -} +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# LOCAL UTILITY PROCS +# proc getsize w { regexp {(^[^+-]*)} [wm geometry $w] foo x return $x } -proc resetGridInfo {} { - # Some window managers, such as mwm, don't reset gridding information - # unless the window is withdrawn and re-mapped. If this procedure - # isn't invoked, the window manager will stay in gridded mode, which - # can cause all sorts of problems. The "wm positionfrom" command is - # needed so that the window manager doesn't ask the user to - # manually position the window when it is re-mapped. - - wm withdraw . - wm positionfrom . user - wm deiconify . -} - -# Procedure that creates a second listbox for checking things related +# mkPartial -- +# +# Creates a second listbox for checking things related # to partially visible lines. - +# proc mkPartial {{w .partial}} { destroy $w toplevel $w @@ -53,19 +51,47 @@ proc mkPartial {{w .partial}} { update } +proc record {name args} { + global log + lappend log [format {%s %.6g %.6g} $name {*}$args] +} + +proc resetGridInfo {} { + # Some window managers, such as mwm, don't reset gridding information + # unless the window is withdrawn and re-mapped. If this procedure + # isn't invoked, the window manager will stay in gridded mode, which + # can cause all sorts of problems. The "wm positionfrom" command is + # needed so that the window manager doesn't ask the user to + # manually position the window when it is re-mapped. + + wm withdraw . + wm positionfrom . user + wm deiconify . +} + +# +# COMMON TEST SETUP +# + +set fixed {Courier -12} + # Create entries in the option database to be sure that geometry options # like border width have predictable values. - option add *Listbox.borderWidth 2 option add *Listbox.selectBorderWidth 1 option add *Listbox.highlightThickness 2 option add *Listbox.font {Helvetica -12 bold} -# Listbox used in 3.* configuration options tests listbox .l pack .l update + resetGridInfo + +# +# TESTS +# + test listbox-1.1 {configuration options} -body { .l configure -activestyle under list [lindex [.l configure -activestyle] 4] [.l cget -activestyle] @@ -349,14 +375,18 @@ test listbox-2.5 {Tk_ListboxCmd procedure} -setup { destroy .l } -result {.l} - -# Listbox used in 3.1 -3.115 tests +# +# COMMON TEST SETUP +# +# For tests listbox-3.1 - 3.115 +# destroy .l listbox .l -width 20 -height 5 -bd 4 -highlightthickness 1 -selectborderwidth 2 pack .l .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 el12 el13 el14 \ el15 el16 el17 update + test listbox-3.1 {ListboxWidgetCmd procedure} -body { .l } -returnCodes error -result {wrong # args: should be ".l option ?arg ...?"} @@ -1126,13 +1156,18 @@ test listbox-3.126 {ListboxWidgetCmd procedure, "yview" option, partial last lin destroy .l } -result {0 0.266667} -# Listbox used in 3.127 -3.137 tests +# +# COMMON TEST SETUP +# +# For tests listbox-3.127 - 3.137 +# destroy .l listbox .l -width 20 -height 5 -bd 4 -highlightthickness 1 -selectborderwidth 2 pack .l .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 el12 el13 el14 \ el15 el16 el17 update + test listbox-3.127 {ListboxWidgetCmd procedure, "xview" option} -body { .l yview foo } -returnCodes error -result {bad listbox index "foo": must be active, anchor, end, @x,y, or an index} @@ -1230,7 +1265,12 @@ test listbox-4.1 {ConfigureListbox procedure} -constraints { } -cleanup { deleteWindows } -result {25x15 185x263} + +# +# COMMON TEST CLEANUP +# resetGridInfo + test listbox-4.2 {ConfigureListbox procedure} -setup { deleteWindows destroy .l @@ -1353,7 +1393,11 @@ test listbox-4.7 {ConfigureListbox procedure} -setup { wm geom . {} } -result {30x20 26x15 26x15} +# +# COMMON TEST CLEANUP +# resetGridInfo + test listbox-4.8 {ConfigureListbox procedure} -setup { destroy .l2 } -body { @@ -1553,12 +1597,15 @@ test listbox-5.6 {ListboxComputeGeometry procedure} -setup { destroy .l } -result {} - -# Listbox used in 6.*, 7.* tests +# +# COMMON TEST SETUP +# +# For tests listbox-6.* and listbox-7.* destroy .l listbox .l -height 2 -xscrollcommand "record x" -yscrollcommand "record y" pack .l update + test listbox-6.1 {InsertEls procedure} -body { .l delete 0 end .l insert end a b c d @@ -1872,7 +1919,12 @@ test listbox-8.1 {ListboxEventProc procedure} -constraints { } -cleanup { destroy .l } -result {20x10 150x178 0 {}} + +# +# COMMON TEST CLEANUP +# resetGridInfo + test listbox-8.2 {ListboxEventProc procedure} -constraints { fonts } -setup { @@ -1930,9 +1982,6 @@ test listbox-9.2 {ListboxCmdDeletedProc procedure, disabling -setgrid} -constrai destroy .top } -result {20x10 150x178} - -# Listbox used in 10.* tests -destroy .l test listbox-10.1 {GetListboxIndex procedure} -setup { destroy .l } -body { @@ -2228,13 +2277,17 @@ test listbox-11.6 {ChangeListboxView procedure, partial last line} -body { destroy .l } -result 11 - -# Listbox used in 12.* tests +# +# COMMON TEST SETUP +# +# For tests listbox-12.* +# destroy .l listbox .l -font $fixed -xscrollcommand "record x" -width 10 .l insert 0 0123456789a123456789b123456789c123456789d123456789e123456789f123456789g123456789h123456789i123456789 pack .l update + test listbox-12.1 {ChangeListboxOffset procedure} -constraints { fonts } -body { @@ -2263,8 +2316,11 @@ test listbox-12.3 {ChangeListboxOffset procedure} -constraints { list [format {%.6g %.6g} {*}[.l xview]] $log } -result {{0.1 0.2} {}} - -# Listbox used in 13.* tests +# +# COMMON TEST SETUP +# +# For tests listbox-13.* +# destroy .l listbox .l -font $fixed -width 10 -height 5 pack .l @@ -2273,6 +2329,7 @@ pack .l update set width [expr [lindex [.l bbox 2] 2] - [lindex [.l bbox 1] 2]] set height [expr [lindex [.l bbox 2] 1] - [lindex [.l bbox 1] 1]] + test listbox-13.1 {ListboxScanTo procedure} -constraints { fonts } -body { @@ -2315,13 +2372,19 @@ test listbox-14.1 {NearestListboxElement procedure, partial last line} -body { mkPartial .partial.l nearest [winfo height .partial.l] } -result 4 -# Listbox used in 14.* tests + +# +# COMMON TEST SETUP +# +# For tests listbox-14.* +# destroy .l listbox .l -font $fixed -width 20 -height 10 .l insert 0 a b c d e f g h i j k l m n o p q r s t .l yview 4 pack .l update + test listbox-14.2 {NearestListboxElement procedure} -constraints { fonts } -body { @@ -2338,12 +2401,16 @@ test listbox-14.4 {NearestListboxElement procedure} -constraints { .l index @50,200 } -result 13 - -# Listbox used in 15.* 16.* and 17.* tests +# +# COMMON TEST SETUP +# +# For tests listbox-15.* 16.* and 17.* +# destroy .l listbox .l -font $fixed -width 20 -height 10 pack .l update + test listbox-15.1 {ListboxSelect procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j k l m n o p @@ -2484,12 +2551,16 @@ test listbox-17.2 {ListboxLostSelection procedure} -setup { destroy .e } -result {0 1 2 3 4} - -# Listbox used in 18.* tests +# +# COMMON TEST SETUP +# +# For tests listbox-18.* +# destroy .l listbox .l -font $fixed -width 10 -height 5 pack .l update + test listbox-18.1 {ListboxUpdateVScrollbar procedure} -body { .l configure -yscrollcommand "record y" set log {} @@ -2525,12 +2596,16 @@ test listbox-18.3 {ListboxUpdateVScrollbar procedure} -body { "gorp 0.0 1.0" (vertical scrolling command executed by listbox)}} - -# Listbox used in 19.* tests +# +# COMMON TEST SETUP +# +# For tests listbox-19.* +# destroy .l listbox .l -font $fixed -width 10 -height 5 pack .l update + test listbox-19.1 {ListboxUpdateVScrollbar procedure} -constraints { fonts } -body { @@ -2874,10 +2949,15 @@ test listbox-23.5 {ConfigureListboxItem, multiple calls} -setup { destroy .l } -result {red orange yellow green blue white violet} -# Listbox used in 23.6 -23.17 tests +# +# COMMON TEST SETUP +# +# For tests listbox-23.6 - 23.17 +# destroy .l listbox .l .l insert end a b c d + test listbox-23.6 {configuration options} -body { .l itemconfigure 0 -background #ff0000 list [lindex [.l itemconfigure 0 -background] 4] [.l itemcget 0 -background] @@ -3211,7 +3291,7 @@ test listbox-32.2 {Bug [5d991b822e]} { } {} # -# CLEANUP +# TESTFILE CLEANUP # resetGridInfo @@ -3219,4 +3299,3 @@ deleteWindows option clear rename getsize {} cleanupTests -return diff --git a/tests/main.tcl b/tests/main.tcl index d7cc999..65e2cd4 100644 --- a/tests/main.tcl +++ b/tests/main.tcl @@ -1,66 +1,46 @@ # main.tcl -- # -# This file is loaded by each test file when invoking "tcltest::loadTestedCommands". -# It performs an initial Tk setup for the root window, and loads, in turn, -# definitions of global utility procs and test constraints. +# This file holds initialization code that is common to all testfiles. +# It performs an initial Tk setup for the root window, imports commands from +# the tcltest namespace, and loads definitions of global utility procs and +# test constraints. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. +if {[namespace exists ::tk::test]} { + # This file has already been sourced by a previous test file in mode -singleproc 1 + return +} + # # SETUP FOR APPLICATION AND ROOT WINDOW # -if {[namespace exists tk::test]} { - # reset windows - deleteWindows - wm geometry . {} - raise . - return +encoding system utf-8 +if {[tcltest::configure -singleproc] == 0} { + # Support test suite invocation by tclsh (as is the case with "-singleproc 1") + package require tk } - -package require tk tk appname tktest wm title . tktest -# If the main window isn't already mapped (e.g. because the tests are -# being run automatically) , specify a precise size for it so that the -# user won't have to position it manually. - -if {![winfo ismapped .]} { - wm geometry . +0+0 - update -} +wm geometry . +0+0 # -# LOAD AND CONFIGURE TEST HARNESS +# IMPORT TCLTEST COMMANDS # -package require tcltest 2.2 -eval tcltest::configure $argv -namespace import -force tcltest::test -namespace import -force tcltest::makeFile -namespace import -force tcltest::removeFile -namespace import -force tcltest::makeDirectory -namespace import -force tcltest::removeDirectory -namespace import -force tcltest::interpreter -namespace import -force tcltest::testsDirectory -namespace import -force tcltest::cleanupTests +namespace import -force tcltest::cleanupTests tcltest::interpreter \ + tcltest::makeDirectory tcltest::makeFile tcltest::removeDirectory \ + tcltest::removeFile tcltest::test tcltest::testsDirectory # # SOURCE DEFINITIONS OF GLOBAL UTILITY PROCS AND CONSTRAINTS # -# Note: tcltest uses [uplevel] to evaluate this script. Therefore, [info script] -# cannot be used to determine the main Tk test directory, and we use -# [tcltest::configure -loadfile] instead. -# -set mainTestDir [file dirname [tcltest::configure -loadfile]] +set mainTestDir [tcltest::configure -testdir] +if {[file tail $mainTestDir] eq "ttk"} { + set mainTestDir [file dirname $mainTestDir] +} source [file join $mainTestDir testutils.tcl] source [file join $mainTestDir constraints.tcl] unset mainTestDir -# -# RESET WINDOWS -# -deleteWindows -wm geometry . {} -raise . - # EOF diff --git a/tests/main.test b/tests/main.test index e481542..c3d0b3c 100644 --- a/tests/main.test +++ b/tests/main.test @@ -1,17 +1,29 @@ # This file contains tests for the tkMain.c file. # -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# # Copyright © 1997 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -eval tcltest::configure $argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# TESTS +# test main-1.1 {StdinProc} -constraints stdio -setup { set script [makeFile {close stdin; exit} script] @@ -112,6 +124,8 @@ test main-3.3 {Tk_ParseArgv: -help option} -setup { interp delete $maininterp } -returnCodes error -match glob -result {Command-specific options:*} -# cleanup +# +# TESTFILE CLEANUP +# + cleanupTests -return diff --git a/tests/menu.test b/tests/menu.test index 1b3bddd..7046508 100644 --- a/tests/menu.test +++ b/tests/menu.test @@ -1,20 +1,34 @@ -# This file is a Tcl script to test menus in Tk. It is -# organized in the standard fashion for Tcl tests. +# This file is a Tcl script to test menus in Tk. # # Copyright © 1995-1997 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -eval tcltest::configure $argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import image imageInit +# +# TESTS +# test menu-1.1 {Tk_MenuCmd procedure} -body { menu @@ -149,9 +163,14 @@ test menu-1.14 {Tk_MenuCmd procedure} -setup { deleteWindows } -result {.m1} -# Used for 2.1 - 2.30 tests +# +# COMMON TEST SETUP +# +# For tests 2.1 - 2.30 +# destroy .m1 menu .m1 + test menu-2.1 {configuration options -activebackground #012345} -body { .m1 configure -activebackground #012345 .m1 cget -activebackground @@ -280,7 +299,12 @@ test menu-2.30 {configuration options -tearoffcommand {any old string}} -body { .m1 configure -tearoffcommand {any old string} .m1 cget -tearoffcommand } -result {any old string} -destroy .m1 + +# +# COMMON TEST SETUP +# +# For tests 2.31 - 2.228 +# # We need to test all of the options with all of the different types of # menu entries. The following code sets up .m1 with 6 items. It then @@ -1193,10 +1217,12 @@ test menu-2.228 {entry configuration options 5 -underline 3p radiobutton} -body .m1 entryconfigure 5 -underline 3p } -returnCodes error -result {bad index "3p": must be integer?[+-]integer?, end?[+-]integer?, or ""} +# +# COMMON TEST CLEANUP +# deleteWindows image delete image1 - test menu-3.1 {MenuWidgetCmd procedure} -setup { destroy .m1 } -body { @@ -2372,7 +2398,6 @@ test menu-8.7 {DestroyMenuEntry} -setup { list [.m2 delete 1] [destroy .m1] } -result {{} {}} - # test menu-9 - Can only change when fonts change on system, which cannot # be done from tcl. test menu-9.1 {ConfigureMenu} -setup { @@ -2705,8 +2730,6 @@ test menu-11.21 {ConfigureMenuEntry} -constraints { imageCleanup } -result {} -unset earthPhotoFile - test menu-12.1 {ConfigureMenuCloneEntries} -setup { deleteWindows @@ -4287,14 +4310,14 @@ test menu-41.14 {identifiers - reserved word} -setup { } -result {2} # -# CLEANUP +# TESTFILE CLEANUP # +unset earthPhotoFile imageFinish deleteWindows testutils forget image cleanupTests -return # Local variables: # mode: tcl diff --git a/tests/menuDraw.test b/tests/menuDraw.test index 95601f4..ccdf36c 100644 --- a/tests/menuDraw.test +++ b/tests/menuDraw.test @@ -1,20 +1,35 @@ -# This file is a Tcl script to test drawing of menus in Tk. It is -# organized in the standard fashion for Tcl tests. +# This file is a Tcl script to test drawing of menus in Tk. # # Copyright © 1996-1997 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -eval tcltest::configure $argv -tcltest::loadTestedCommands -namespace import -force tcltest::test +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import image imageInit +# +# TESTS +# + test menuDraw-1.1 {TkMenuInitializeDrawingFields} -setup { deleteWindows } -body { @@ -711,14 +726,13 @@ test menuDraw-17.2 {AdjustMenuCoords - menu} -constraints { } -result {} # -# CLEANUP +# TESTFILE CLEANUP # imageFinish deleteWindows testutils forget image cleanupTests -return # Local variables: # mode: tcl diff --git a/tests/menubut.test b/tests/menubut.test index cbfb977..d1f994f 100644 --- a/tests/menubut.test +++ b/tests/menubut.test @@ -1,25 +1,42 @@ -# This file is a Tcl script to test menubuttons in Tk. It is -# organized in the standard fashion for Tcl tests. +# This file is a Tcl script to test menubuttons in Tk. # # Copyright © 1994 The Regents of the University of California. # Copyright © 1994-1996 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -# XXX This test file is woefully incomplete right now. If any part -# XXX of a procedure has tests then the whole procedure has tests, -# XXX but many procedures have no tests. +# NOTE +# +# This test file is woefully incomplete right now. Many procedures have no +# tests. The tests for ConfigureMenuButton are incomplete. +# + +# +# TESTFILE INITIALIZATION +# -package require tcltest 2.2 -eval tcltest::configure $argv -tcltest::loadTestedCommands -namespace import -force tcltest::test +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import image imageInit +# +# COMMON TEST SETUP +# + # Create entries in the option database to be sure that geometry options # like border width have predictable values. @@ -30,10 +47,14 @@ option add *Button.borderWidth 2 option add *Button.highlightThickness 2 option add *Button.font {Helvetica -12 bold} - menubutton .mb -text "Test" pack .mb update + +# +# TESTS +# + test menubutton-1.1 {configuration options} -body { .mb configure -activebackground #012345 .mb cget -activebackground @@ -318,11 +339,14 @@ test menubutton-1.59 {configuration options} -body { .mb configure -wraplength 6x } -returnCodes error -result {expected screen distance but got "6x"} - +# +# COMMON TEST SETUP +# deleteWindows menubutton .mb -text "Test" pack .mb update + test menubutton-2.1 {Tk_MenubuttonCmd procedure} -body { menubutton } -returnCodes error -result {wrong # args: should be "menubutton pathName ?-option value ...?"} @@ -346,10 +370,13 @@ test menubutton-2.5 {Tk_ButtonCmd procedure} -setup { winfo exists .mb } -result 0 - +# +# COMMON TEST SETUP +# deleteWindows menubutton .mb -text "Test Menu" pack .mb + test menubutton-3.1 {MenuButtonWidgetCmd procedure} -body { .mb } -returnCodes error -result {wrong # args: should be ".mb option ?arg ...?"} @@ -386,10 +413,11 @@ test menubutton-3.10 {ButtonWidgetCmd procedure, "configure" option} -body { test menubutton-3.11 {ButtonWidgetCmd procedure, "configure" option} -body { .mb foobar } -returnCodes error -result {bad option "foobar": must be cget or configure} -deleteWindows -# XXX Need to add tests for several procedures here. The tests for XXX -# XXX ConfigureMenuButton aren't complete either. XXX +# +# COMMON TEST CLEANUP +# +deleteWindows test menubutton-4.1 {ConfigureMenuButton procedure} -setup { deleteWindows @@ -517,10 +545,6 @@ test menubutton-4.11 {ConfigureMenuButton procedure - bad direction} -setup { deleteWindows } -result {below {}} - - -# XXX Need to add tests for several procedures here. XXX - test menubutton-5.1 {MenuButtonEventProc procedure} -setup { deleteWindows set x {} @@ -546,11 +570,15 @@ test menubutton-6.1 {MenuButtonCmdDeletedProc procedure} -setup { deleteWindows } -result {{} {}} +# +# COMMON TEST SETUP +# if {[tk windowingsystem] eq "aqua"} { set extraWidth 36 } else { set extraWidth 0 } + test menubutton-7.1 {ComputeMenuButtonGeometry procedure} -constraints { testImageType } -setup { @@ -784,7 +812,7 @@ test menubutton-9.2 {Bug [5d991b822e]} { } {} # -# CLEANUP +# TESTFILE CLEANUP # deleteWindows @@ -793,7 +821,6 @@ imageFinish testutils forget image cleanupTests -return # Local variables: # mode: tcl diff --git a/tests/message.test b/tests/message.test index 34924a8..422026e 100644 --- a/tests/message.test +++ b/tests/message.test @@ -1,16 +1,31 @@ # This file is a Tcl script to test out the "message" command -# of Tk. It is organized in the standard fashion for Tcl tests. +# of Tk. # # Copyright © 1994 The Regents of the University of California. # Copyright © 1994-1996 Sun Microsystems, Inc. # Copyright © 1998-2000 Ajuba Solutions. # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -tcltest::loadTestedCommands -eval tcltest::configure $argv +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows +# +# TESTS +# test message-1.1 {configuration option: "anchor"} -setup { message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} @@ -508,5 +523,8 @@ test message-4.2 {Bug [5d991b822e]} { unset new } {} +# +# TESTFILE CLEANUP +# + cleanupTests -return diff --git a/tests/msgbox.test b/tests/msgbox.test index 0e92dfa..95064ea 100644 --- a/tests/msgbox.test +++ b/tests/msgbox.test @@ -1,18 +1,49 @@ # This file is a Tcl script to test out Tk's "tk_messageBox" command. -# It is organized in the standard fashion for Tcl tests. # # Copyright © 1996 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -eval tcltest::configure $argv -tcltest::loadTestedCommands -namespace import -force tcltest::test +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import dialog +# +# LOCAL UTILITY PROCS +# + +proc ChooseMsg {parent btn} { + if {! $::dialogIsNative} { + after 100 SendButtonPress $parent $btn mouse + } +} + +proc ChooseMsgByKey {parent btn} { + if {! $::dialogIsNative} { + after 100 SendButtonPress $parent $btn key + } +} + +# +# TESTS +# + test msgbox-1.1.1 {tk_messageBox command} -constraints notAqua -body { tk_messageBox -foo } -returnCodes error -result {bad option "-foo": must be -default, -detail, -icon, -message, -parent, -title, or -type} @@ -76,19 +107,6 @@ test msgbox-1.19 {tk_messageBox command} -body { tk_messageBox -parent foo.bar } -returnCodes error -result {bad window path name "foo.bar"} - -proc ChooseMsg {parent btn} { - if {! $::dialogIsNative} { - after 100 SendButtonPress $parent $btn mouse - } -} - -proc ChooseMsgByKey {parent btn} { - if {! $::dialogIsNative} { - after 100 SendButtonPress $parent $btn key - } -} - # # Try out all combinations of (type) x (default button) and # (type) x (icon). @@ -414,9 +432,8 @@ test msgbox-3.2 {tk_messageBox handles iconified parent} -constraints { } -result {ok} # -# CLEANUP +# TESTFILE CLEANUP # testutils forget dialog cleanupTests -return diff --git a/tests/obj.test b/tests/obj.test index 87e4a95..3f22d4f 100644 --- a/tests/obj.test +++ b/tests/obj.test @@ -1,14 +1,29 @@ # This file is a Tcl script to test new object types in Tk. -# It is organized in the standard fashion for Tcl tests. # # Copyright © 1997 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -eval tcltest::configure $argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# TESTS +# test obj-1.1 {TkGetPixelsFromObj} -body { } -result {} @@ -22,7 +37,8 @@ test obj-3.1 {DupPixelInternalRep} -body { test obj-4.1 {SetPixelFromAny} -body { } -result {} +# +# TESTFILE CLEANUP +# -# cleanup cleanupTests -return diff --git a/tests/option.test b/tests/option.test index ad802bd..8d2f353 100644 --- a/tests/option.test +++ b/tests/option.test @@ -1,18 +1,37 @@ # This file is a Tcl script to test out the option-handling facilities -# of Tk. It is organized in the standard fashion for Tcl tests. +# of Tk. # # Copyright © 1991-1993 The Regents of the University of California. # Copyright © 1994 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -eval tcltest::configure $argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# LOCAL TEST CONSTRAINTS +# testConstraint appNameIsTktest [expr {[winfo name .] eq "tktest"}] +# +# COMMON TEST SETUP +# + deleteWindows set appName [winfo name .] @@ -39,6 +58,10 @@ option add $appName.Class1.Class3.y brown option add $appName*op6*Color2 black option add $appName*Class1.op1.Color2 grey +# +# TESTS +# + test option-1.1 {basic option retrieval} -body { option get . x Color1 } -result blue @@ -178,12 +201,15 @@ test option-7.6 {basic option retrieval} -body { option get .op2.op5 z Color2 } -result purple +# +# COMMON TEST SETUP +# # Now try similar tests to above, except jump around non-hierarchically # between windows to make sure that the option stacks are pushed and # popped correctly. - option get . foo Foo + test option-8.1 {stack pushing/popping} -body { option get .op2.op5 x Color1 } -result orange @@ -283,9 +309,12 @@ test option-12.6 {stack pushing/popping} -body { option get .op1 z Color2 } -result {} +# +# COMMON TEST SETUP +# # Test the major priority levels (widgetDefault, etc.) - # Configurations for tests 13.* +# option clear option add $appName.op1.a 100 100 option add $appName.op1.A interactive interactive @@ -309,11 +338,21 @@ test option-13.4 {priority levels} -body { test option-13.5 {priority levels} -body { option get .op1 c C } -result widgetDefault + +# +# COMMON TEST SETUP +# option add $appName.op1.B file2 widget + test option-13.6 {priority levels} -body { option get .op1 c B } -result startupFile + +# +# COMMON TEST SETUP +# option add $appName.op1.B file2 startupFile + test option-13.7 {priority levels} -body { option get .op1 c B } -result file2 @@ -358,8 +397,11 @@ test option-14.12 {error conditions} -body { option get .gorp.gorp a A } -returnCodes error -result {bad window path name ".gorp.gorp"} - +# +# COMMON TEST SETUP +# set option1 [file join [testsDirectory] option.file1] + test option-15.1 {database files} -body { list [catch {option read non-existent} msg] [string tolower $msg] } -result {1 {couldn't open "non-existent": no such file or directory}} @@ -399,9 +441,13 @@ test option-15.10 {database files} -body { set option2 [file join [testsDirectory] option.file2] option read $option2 } -returnCodes error -result {missing colon on line 2} -set option3 [file join [testsDirectory] option.file3] -option read $option3 -test option-15.11 {database files} {option get . {x 4} color} brówn + +test option-15.11 {database files} -setup { + set option3 [file join [testsDirectory] option.file3] + option read $option3 +} -body { + option get . {x 4} color +} -result brówn test option-16.1 {ReadOptionFile} -body { set option4 [makeFile {} option.file4] @@ -415,29 +461,27 @@ test option-16.1 {ReadOptionFile} -body { removeFile $option4 } -result {true false} -set opt162val {label { +test option-16.2 {ticket 766ef52f3} -setup { + set expected [split {label { foo bar } -} -set opt162list [split $opt162val \n] - -test option-16.2 {ticket 766ef52f3} -body { +} \n] +} -body { set option5 [makeFile {} option.file5] set file [open $option5 w] fconfigure $file -translation crlf - puts $file "*notok: $opt162list" + puts $file "*notok: $expected" close $file option read $option5 userDefault - option get . notok notok + expr {[option get . notok notok] eq $expected} } -cleanup { removeFile $option5 -} -result $opt162list + unset expected +} -result 1 -deleteWindows +# +# TESTFILE CLEANUP +# -# cleanup +deleteWindows cleanupTests -return - - - diff --git a/tests/pack.test b/tests/pack.test index 3a332ed..5df09aa 100644 --- a/tests/pack.test +++ b/tests/pack.test @@ -1,15 +1,30 @@ -# This file is a Tcl script to test out the "pack" command of Tk. It is -# organized in the standard fashion for Tcl tests. +# This file is a Tcl script to test out the "pack" command of Tk. # # Copyright © 1993 The Regents of the University of California. # Copyright © 1994 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -eval tcltest::configure $argv -tcltest::loadTestedCommands -namespace import -force tcltest::test +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# COMMON TEST SETUP +# # Create some test windows. @@ -28,6 +43,10 @@ foreach i {a b c d} { .pack.c config -width 80 -height 80 .pack.d config -width 40 -height 30 +# +# TESTS +# + test pack-1.1 {-side option} -setup { pack forget .pack.a .pack.b .pack.c .pack.d } -body { @@ -724,7 +743,11 @@ test pack-6.13 {-expand option} -setup { destroy .pack2 } -result {38x42+181+45 38x42+181+178 38x42+181+312} +# +# COMMON TEST SETUP +# wm geometry .pack {} + test pack-7.1 {requesting size for parent} -setup { pack forget .pack.a .pack.b .pack.c .pack.d } -body { @@ -782,6 +805,10 @@ test pack-7.7 {requesting size for parent} -setup { list [winfo reqwidth .pack] [winfo reqheight .pack] } -result {100 110} +# +# COMMON TEST SETUP +# + # For the tests below, create a couple of "pad" windows to shrink # the available space for the remaining windows. The tests have to # be done this way rather than shrinking the whole window, because @@ -795,71 +822,104 @@ pack .pack.right -side right pack .pack.bottom -side bottom pack .pack.a .pack.b .pack.c -side top update + test pack-8.1 {insufficient space} -body { list [winfo geometry .pack.a] [winfo ismapped .pack.a] \ [winfo geometry .pack.b] [winfo ismapped .pack.b] \ [winfo geometry .pack.c] [winfo ismapped .pack.c] } -result {20x40+30+0 1 50x30+15+40 1 80x80+0+70 1} -wm geom .pack 270x250 -update -test pack-8.2 {insufficient space} -body { + +test pack-8.2 {insufficient space} -setup { + wm geom .pack 270x250 + update +} -body { list [winfo geometry .pack.a] [winfo ismapped .pack.a] \ [winfo geometry .pack.b] [winfo ismapped .pack.b] \ [winfo geometry .pack.c] [winfo ismapped .pack.c] } -result {20x40+25+0 1 50x30+10+40 1 70x30+0+70 1} -wm geom .pack 240x220 -update -test pack-8.3 {insufficient space} -body { + +test pack-8.3 {insufficient space} -setup { + wm geom .pack 240x220 + update +} -body { list [winfo geometry .pack.a] [winfo ismapped .pack.a] \ [winfo geometry .pack.b] [winfo ismapped .pack.b] \ [winfo geometry .pack.c] [winfo ismapped .pack.c] } -result {20x40+10+0 1 40x30+0+40 1 70x30+0+70 0} -wm geom .pack 350x350 -update -test pack-8.4 {insufficient space} -body { + +test pack-8.4 {insufficient space} -setup { + wm geom .pack 350x350 + update +} -body { list [winfo geometry .pack.a] [winfo ismapped .pack.a] \ [winfo geometry .pack.b] [winfo ismapped .pack.b] \ [winfo geometry .pack.c] [winfo ismapped .pack.c] } -result {20x40+65+0 1 50x30+50+40 1 80x80+35+70 1} -wm geom .pack {} + +# +# COMMON TEST SETUP +# + pack .pack.a -side left pack .pack.b -side right pack .pack.c -side left update -test pack-8.5 {insufficient space} -body { + +test pack-8.5 {insufficient space} -setup { + wm geom .pack {} + update +} -body { list [winfo geometry .pack.a] [winfo ismapped .pack.a] \ [winfo geometry .pack.b] [winfo ismapped .pack.b] \ [winfo geometry .pack.c] [winfo ismapped .pack.c] } -result {20x40+0+20 1 50x30+100+25 1 80x80+20+0 1} -wm geom .pack 320x180 -update -test pack-8.6 {insufficient space} -body { + +test pack-8.6 {insufficient space} -setup { + wm geom .pack 320x180 + update +} -body { list [winfo geometry .pack.a] [winfo ismapped .pack.a] \ [winfo geometry .pack.b] [winfo ismapped .pack.b] \ [winfo geometry .pack.c] [winfo ismapped .pack.c] } -result {20x30+0+0 1 50x30+70+0 1 50x30+20+0 1} + +# +# COMMON TEST SETUP +# wm geom .pack 250x180 update + test pack-8.7 {insufficient space} -body { list [winfo geometry .pack.a] [winfo ismapped .pack.a] \ [winfo geometry .pack.b] [winfo ismapped .pack.b] \ [winfo geometry .pack.c] [winfo ismapped .pack.c] } -result {20x30+0+0 1 30x30+20+0 1 50x30+20+0 0} -pack forget .pack.b -update -test pack-8.8 {insufficient space} -body { + +test pack-8.8 {insufficient space} -setup { + pack forget .pack.b + update +} -body { list [winfo geometry .pack.a] [winfo ismapped .pack.a] \ [winfo geometry .pack.b] [winfo ismapped .pack.b] \ [winfo geometry .pack.c] [winfo ismapped .pack.c] } -result {20x30+0+0 1 30x30+20+0 0 30x30+20+0 1} + +# +# COMMON TEST SETUP +# pack .pack.b -side right -after .pack.a wm geom .pack {} update + test pack-8.9 {insufficient space} -body { list [winfo geometry .pack.a] [winfo ismapped .pack.a] \ [winfo geometry .pack.b] [winfo ismapped .pack.b] \ [winfo geometry .pack.c] [winfo ismapped .pack.c] } -result {20x40+0+20 1 50x30+100+25 1 80x80+20+0 1} + +# +# COMMON TEST SETUP +# pack forget .pack.right .pack.bottom test pack-9.1 {window ordering} -setup { @@ -1185,7 +1245,6 @@ test pack-12.14 {command options and errors} -setup { } -body { pack .pack.a -in z } -returnCodes error -result {bad window path name "z"} -set pad [winfo pixels .pack 1c] test pack-12.15 {command options and errors} -setup { pack forget .pack.a .pack.b .pack.c .pack.d } -body { @@ -1751,9 +1810,11 @@ test pack-20.6 {<<NoManagedChild>> does not fire on last pack forget if propagat destroy .1 } -result 0 -# cleanup +# +# TESTFILE CLEANUP +# + cleanupTests -return # Local Variables: # mode: tcl diff --git a/tests/packgrid.test b/tests/packgrid.test index 63e5b86..682180d 100644 --- a/tests/packgrid.test +++ b/tests/packgrid.test @@ -1,14 +1,29 @@ # This file is a Tcl script to test out interaction between Tk's "pack" and # "grid" commands. -# It is organized in the standard fashion for Tcl tests. # # Copyright © 2008 Peter Spjuth # All rights reserved. -package require tcltest 2.2 -eval tcltest::configure $argv -tcltest::loadTestedCommands -namespace import -force tcltest::* +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# TESTS +# test packgrid-1.1 {pack and grid in same container window} -setup { grid propagate . true @@ -276,5 +291,8 @@ test packgrid-4.2 {content stolen after container destruction - bug [aa7679685e] destroy .b } -result {} +# +# TESTFILE CLEANUP +# + cleanupTests -return diff --git a/tests/panedwindow.test b/tests/panedwindow.test index 7b251a0..58d16b1 100644 --- a/tests/panedwindow.test +++ b/tests/panedwindow.test @@ -1,15 +1,30 @@ -# This file is a Tcl script to test entry widgets in Tk. It is -# organized in the standard fashion for Tcl tests. +# This file is a Tcl script to test paned window widgets in Tk. # # Copyright © 1994 The Regents of the University of California. # Copyright © 1994-1997 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -eval tcltest::configure $argv -tcltest::loadTestedCommands -namespace import -force tcltest::test +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# COMMON TEST SETUP +# deleteWindows # Panedwindow for tests 1.* @@ -17,6 +32,11 @@ panedwindow .p # Buttons for tests 1.33 - 1.52 .p add [button .b] .p add [button .c] + +# +# TESTS +# + test panedwindow-1.1 {configuration options: -background (good)} -body { .p configure -background #ff0000 list [lindex [.p configure -background] 4] [.p cget -background] @@ -289,7 +309,6 @@ test panedwindow-1.57 {configuration options: -width (good)} -body { test panedwindow-1.58 {configuration options: -width (bad)} -body { .p paneconfigure .b -width badValue } -returnCodes error -result {expected screen distance or "" but got "badValue"} -deleteWindows test panedwindow-2.1 {panedwindow widget command} -setup { @@ -5543,9 +5562,8 @@ test panedwindow-29.2 {display on depths other than the default one} -constraint deleteWindows } -result {} +# +# TESTFILE CLEANUP +# -# cleanup cleanupTests -return - - diff --git a/tests/pkgconfig.test b/tests/pkgconfig.test index 4b73a9a..a094211 100644 --- a/tests/pkgconfig.test +++ b/tests/pkgconfig.test @@ -1,9 +1,4 @@ -# -*- tcl -*- -# Commands covered: pkgconfig -# -# This file contains a collection of tests for one or more of the Tk -# built-in commands. Sourcing this file into Tk runs the tests and -# generates output for errors. No output means no errors were found. +# This file is a Tcl script to test the command "pkgconfig". # # Copyright © 1991-1993 The Regents of the University of California. # Copyright © 1994-1996 Sun Microsystems, Inc. @@ -13,10 +8,26 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2.2 -namespace import ::tcltest::* -eval tcltest::configure $argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# TESTS +# test pkgconfig-1.1 {query keys} -constraints {nonwin} -body { lsort [::tk::pkgconfig list] @@ -62,6 +73,8 @@ test pkgconfig-2.5 {error: query with to many arguments} { set msg } {wrong # args: should be "::tk::pkgconfig subcommand ?arg?"} -# cleanup +# +# TESTFILE CLEANUP +# + cleanupTests -return diff --git a/tests/place.test b/tests/place.test index 96cda0e..d31b5ba 100644 --- a/tests/place.test +++ b/tests/place.test @@ -1,22 +1,44 @@ -# This file is a Tcl script to test out the "place" command. It is -# organized in the standard fashion for Tcl tests. +# This file is a Tcl script to test out the "place" command. # # Copyright © 1995 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -eval tcltest::configure $argv -tcltest::loadTestedCommands +# NOTE +# +# This test file is woefully incomplete. At present, only a +# few of the features are tested. + +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# LOCAL TEST CONSTRAINTS +# # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] -# XXX - This test file is woefully incomplete. At present, only a -# few of the features are tested. +# +# COMMON TEST SETUP +# +# For tests 1.* - 8.* +# -# Widgets used in tests 1.* - 8.* toplevel .t -width 300 -height 200 -bd 0 wm geom .t +0+0 frame .t.f -width 154 -height 84 -bd 2 -relief raised @@ -24,6 +46,10 @@ place .t.f -x 48 -y 38 frame .t.f2 -width 30 -height 60 -bd 2 -relief raised update +# +# TESTS +# + test place-1.1 {Tk_PlaceCmd procedure, "info" option} -setup { place forget .t.f2 } -body { @@ -302,8 +328,11 @@ test place-8.2 {PlaceStructureProc, mapping and unmapping content} -constraints update lappend result [winfo ismapped .t.f2] } -result {1 0 42 32 0 1} -destroy .t +# +# COMMON TEST CLEANUP +# +destroy .t test place-9.1 {PlaceObjCmd} -body { place @@ -523,10 +552,8 @@ test place-14.1 {memory leak testing} -constraints memory -setup { rename stress {} } -result {0 0 0} +# +# TESTFILE CLEANUP +# -# cleanup cleanupTests -return - - - diff --git a/tests/raise.test b/tests/raise.test index 7e6b0bd..ea24604 100644 --- a/tests/raise.test +++ b/tests/raise.test @@ -1,38 +1,37 @@ # This file is a Tcl script to test out Tk's "raise" and # "lower" commands, plus associated code to manage window -# stacking order. It is organized in the standard fashion -# for Tcl tests. +# stacking order. # # Copyright © 1993-1994 The Regents of the University of California. # Copyright © 1994 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -eval tcltest::configure $argv -tcltest::loadTestedCommands -namespace import -force tcltest::test +# +# TESTFILE INITIALIZATION +# -# Procedure to create a bunch of overlapping windows, which should -# make it easy to detect differences in order. +package require tcltest 2.2; # needed in mode -singleproc 0 -wm geometry . +400+400 -proc raise_setup {} { - destroy {*}[winfo children .raise] - update idletasks - foreach i {a b c d e} { - label .raise.$i -text $i -relief raised -bd 2 - } - place .raise.a -x 20 -y 60 -width 60 -height 80 - place .raise.b -x 60 -y 60 -width 60 -height 80 - place .raise.c -x 100 -y 60 -width 60 -height 80 - place .raise.d -x 40 -y 20 -width 100 -height 60 - place .raise.e -x 40 -y 120 -width 100 -height 60 -} +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows -# Procedure to return information about which windows are on top -# of which other windows. +# +# LOCAL UTILITY PROCS +# +# raise_getOrder -- +# +# Return information about which windows are on top of which other windows. +# proc raise_getOrder {} { set x [winfo rootx .raise] set y [winfo rooty .raise] @@ -46,8 +45,10 @@ proc raise_getOrder {} { [winfo name [winfo containing [expr $x+130] [expr $y+130]]] } -# Procedure to set up a collection of top-level windows - +# raise_makeToplevels -- +# +# Set up a collection of top-level windows +# proc raise_makeToplevels {} { deleteWindows foreach i {.raise1 .raise2 .raise3} { @@ -57,9 +58,35 @@ proc raise_makeToplevels {} { } } +# raise_setup -- +# +# Create a bunch of overlapping windows, which should make it easy to detect +# differences in order. +# +proc raise_setup {} { + destroy {*}[winfo children .raise] + update idletasks + foreach i {a b c d e} { + label .raise.$i -text $i -relief raised -bd 2 + } + place .raise.a -x 20 -y 60 -width 60 -height 80 + place .raise.b -x 60 -y 60 -width 60 -height 80 + place .raise.c -x 100 -y 60 -width 60 -height 80 + place .raise.d -x 40 -y 20 -width 100 -height 60 + place .raise.e -x 40 -y 120 -width 100 -height 60 +} + +# +# COMMON TEST SETUP +# + +wm geometry . +400+400 toplevel .raise wm geom .raise 250x200+0+0 +# +# TESTS +# test raise-1.1 {preserve creation order} -body { raise_setup @@ -312,9 +339,9 @@ test raise-7.8 {errors in raise/lower commands} -body { lower . badName4 } -returnCodes error -result {bad window path name "badName4"} -deleteWindows +# +# TESTFILE CLEANUP +# -# cleanup +deleteWindows cleanupTests -return - diff --git a/tests/safe.test b/tests/safe.test index ea1015f..0a71f27 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -1,35 +1,52 @@ -# This file is a Tcl script to test the Safe Tk facility. It is organized in -# the standard fashion for Tk tests. +# This file is a Tcl script to test the Safe Tk facility. # # Copyright © 1994 The Regents of the University of California. # Copyright © 1994-1995 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -eval tcltest::configure $argv -tcltest::loadTestedCommands -namespace import -force tcltest::test - -## NOTE: Any time tests fail here with an error like: - -# Can't find a usable tk.tcl in the following directories: -# {$p(:26:)} +# NOTE +# +# Any time tests fail here with an error like: # -# $p(:26:)/tk.tcl: script error -# script error -# invoked from within -# "source {$p(:26:)/tk.tcl}" -# ("uplevel" body line 1) -# invoked from within -# "uplevel #0 [list source $file]" +# Can't find a usable tk.tcl in the following directories: +# {$p(:26:)} # +# $p(:26:)/tk.tcl: script error +# script error +# invoked from within +# "source {$p(:26:)/tk.tcl}" +# ("uplevel" body line 1) +# invoked from within +# "uplevel #0 [list source $file]" # -# This probably means that tk wasn't installed properly. +# +# This probably means that tk wasn't installed properly. +# +# it indicates that something went wrong sourcing tk.tcl. +# Ensure that any changes that occurred to tk.tcl will work or are properly +# prevented in a safe interpreter. -- hobbs -## it indicates that something went wrong sourcing tk.tcl. -## Ensure that any changes that occurred to tk.tcl will work or are properly -## prevented in a safe interpreter. -- hobbs +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# COMMON TEST SETUP +# # The set of hidden commands is platform dependent: @@ -64,7 +81,11 @@ if {[llength [info commands send]]} { set saveAutoPath $::auto_path set auto_path [list [info library] $::tk_library] set hidden_cmds [lsort $hidden_cmds] - + +# +# TESTS +# + test safe-1.1 {Safe Tk loading into an interpreter} -setup { catch {safe::interpDelete a} } -body { @@ -246,12 +267,14 @@ test safe-7.1 {canvas printing} -body { } -cleanup { safe::interpDelete $i } -returnCodes ok -match glob -result * - -# cleanup + +# +# TESTFILE CLEANUP +# + set ::auto_path $saveAutoPath unset hidden_cmds cleanupTests -return # Local Variables: # mode: tcl diff --git a/tests/safePrimarySelection.test b/tests/safePrimarySelection.test index 84d2d0f..cf45065 100644 --- a/tests/safePrimarySelection.test +++ b/tests/safePrimarySelection.test @@ -1,26 +1,17 @@ -# This file is a Tcl script to test entry widgets in Tk. It is -# organized in the standard fashion for Tcl tests. +# This file is a Tcl script to test that a Safe Base interpreter cannot write +# to the PRIMARY selection. # # Copyright © 1994 The Regents of the University of California. # Copyright © 1994-1997 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -eval tcltest::configure $argv -tcltest::loadTestedCommands - -# Import utility procs for specific functional areas -testutils import child - -# ------------------------------------------------------------------------------ -# Tests that a Safe Base interpreter cannot write to the PRIMARY selection. -# ------------------------------------------------------------------------------ +# NOTES +# # - Tests 3.*, 6.* test that the fix for ticket de156e9efe implemented in branch # bug-de156e9efe has been applied and still works. They test that a Safe Base # child interpreter cannot write to the PRIMARY selection. -# - The other tests verify that the parent interpreter and an child interpreter +# - The other tests verify that the parent interpreter and a child interpreter # CAN write to the PRIMARY selection, and therefore that the test scripts # themselves are valid. # - A text, entry, ttk::entry, listbox, spinbox or ttk::spinbox widget can have @@ -31,7 +22,30 @@ testutils import child # - The spinbox, ttk::spinbox are variants of entry, ttk::entry respectively. # - The command "childTkInterp" is not needed for Safe Base children because # safe::loadTk does something similar and works correctly. -# ------------------------------------------------------------------------------ + +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# Import utility procs for specific functional areas +testutils import child + +# +# COMMON TEST SETUP +# namespace eval ::_test_tmp {} @@ -184,6 +198,10 @@ set ::_test_tmp::script { # Do this once for the parent interpreter. eval $::_test_tmp::script +# +# TESTS +# + test safePrimarySelection-1.1 {parent interpreter, text, no existing selection} -setup { catch {interp delete child2} destroy {*}[winfo children .] @@ -1185,10 +1203,9 @@ test safePrimarySelection-6.10 {IMPORTANT, safe interpreter, ttk::spinbox spun/s } -result {OLD_VALUE----OLD_VALUE} # -# CLEANUP +# TESTFILE CLEANUP # namespace delete ::_test_tmp testutils forget child cleanupTests -return diff --git a/tests/scale.test b/tests/scale.test index 7d42070..1898522 100644 --- a/tests/scale.test +++ b/tests/scale.test @@ -1,15 +1,27 @@ # This file is a Tcl script to test out the "scale" command -# of Tk. It is organized in the standard fashion for Tcl tests. +# of Tk. # # Copyright © 1994 The Regents of the University of California. # Copyright © 1994-1996 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -eval tcltest::configure $argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows # Create entries in the option database to be sure that geometry options # like border width have predictable values. @@ -18,11 +30,19 @@ option add *Scale.borderWidth 2 option add *Scale.highlightThickness 2 option add *Scale.font {Helvetica -12 bold} -# Widget used in 1.* tests +# +# COMMON TEST SETUP +# +# For tests 1.* +# scale .s -from 100 -to 300 pack .s update +# +# TESTS +# + test scale-1.1 {configuration options} -body { .s configure -activebackground #ff0000 .s cget -activebackground @@ -317,8 +337,11 @@ test scale-1.69 {configuration options} -body { test scale-1.70 {configuration options} -body { .s configure -width badValue } -returnCodes error -result {expected screen distance but got "badValue"} -destroy .s +# +# COMMON TEST CLEANUP +# +destroy .s test scale-2.1 {Tk_ScaleCmd procedure} -body { scale @@ -338,12 +361,16 @@ test scale-2.5 {Tk_ScaleCmd procedure} -body { winfo children . } -result {} - -# Widget used in 3.* tests +# +# COMMON TEST SETUP +# +# For tests 3.* +# destroy .s scale .s -from 100 -to 200 pack .s update idletasks + test scale-3.1 {ScaleWidgetCmd procedure} -body { .s } -returnCodes error -result {wrong # args: should be ".s option ?arg ...?"} @@ -423,7 +450,14 @@ test scale-3.18 {ScaleWidgetCmd procedure, get option} -body { .s set 150 .s get 37 34 } -result {119.5} + +# +# COMMON TEST SETUP +# +# For tests from scale-3.19 +# .s configure -resolution 1 + test scale-3.19 {ScaleWidgetCmd procedure, identify option} -body { .s identify } -returnCodes error -result {wrong # args: should be ".s identify x y"} @@ -476,6 +510,10 @@ test scale-3.30 {ScaleWidgetCmd procedure} -body { test scale-3.31 {ScaleWidgetCmd procedure} -body { .s co } -returnCodes error -result {ambiguous option "co": must be cget, configure, coords, get, identify, or set} + +# +# COMMON TEST CLEANUP +# destroy .s test scale-3.32 {ScaleWidgetCmd procedure, Tk_Preserve} -setup { @@ -579,11 +617,16 @@ test scale-5.7 {ConfigureScale procedure} -setup { deleteWindows } -returnCodes error -result {bad state "bogus": must be active, disabled, or normal} +# +# COMMON TEST SETUP +# +# For tests scale-6.* +# -# Widget used in 6.* tests destroy .s scale .s -orient horizontal -length 200 pack .s + test scale-6.1 {ComputeFormat procedure} -body { .s configure -from 10 -to 100 -resolution 10 .s set 49.3 @@ -693,8 +736,11 @@ test scale-6.21 {ComputeFormat procedure} -body { .s set 1001.23456789 .s get } -result {1001.235} -destroy .s +# +# COMMON TEST CLEANUP +# +destroy .s test scale-7.1 {ComputeScaleGeometry procedure} -constraints { nonPortable fonts @@ -922,10 +968,15 @@ test scale-8.9 {ScaleElement procedure} -setup { deleteWindows } -result {trough1 slider slider trough2} +# +# COMMON TEST SETUP +# +# For tests scale-9.* +# -#widget used in 9.* tests destroy .s pack [scale .s] + test scale-9.1 {PixelToValue procedure} -body { .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2 update @@ -972,8 +1023,11 @@ test scale-9.9 {PixelToValue procedure} -body { update .s get 76 152 } -result 65 -destroy .s +# +# COMMON TEST CLEANUP +# +destroy .s test scale-10.1 {ValueToPixel procedure} -constraints { fonts @@ -1050,11 +1104,15 @@ test scale-12.1 {ScaleCmdDeletedProc procedure} -setup { deleteWindows } -result {{} {}} - -# Widget used in 13.* tests +# +# COMMON TEST SETUP +# +# For tests scale-13.* +# destroy .s pack [scale .s] update + test scale-13.1 {SetScaleValue procedure} -body { .s configure -from 0 -to 100 -command {set x} -variable y update @@ -1072,7 +1130,14 @@ test scale-13.3 {SetScaleValue procedure} -body { .s set 105 .s get } -result 100 + +# +# COMMON TEST SETUP +# +# For tests scale-13.4 - +# .s configure -from 100 -to 0 + test scale-13.4 {SetScaleValue procedure} -body { .s set -3 .s get @@ -1099,11 +1164,15 @@ test scale-13.6 {SetScaleValue procedure} -body { list $x $traceInfo } -result {untouched empty} - -# Widget used in 14.* tests +# +# COMMON TEST SETUP +# +# For tests from scale-14.1 +# destroy .s pack [scale .s] update + test scale-14.1 {RoundValueToResolution procedure} -body { .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2 \ -orient horizontal -resolution 4.0 @@ -1181,6 +1250,10 @@ test scale-14.12 {RoundValueToResolution procedure} -body { update .s get 86 152 } -result {168.75} + +# +# COMMON TEST CLEANUP +# destroy .s test scale-14.13 {RoundValueToResolution procedure, round-off errors} -setup { @@ -1617,8 +1690,9 @@ test scale-22.2 {Bug [5d991b822e]} { unset new } {} -option clear +# +# TESTFILE CLEANUP +# -# cleanup +option clear cleanupTests -return diff --git a/tests/scrollbar.test b/tests/scrollbar.test index d351d74..192e1dc 100644 --- a/tests/scrollbar.test +++ b/tests/scrollbar.test @@ -7,9 +7,32 @@ # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -eval tcltest::configure $argv -tcltest::loadTestedCommands +# NOTE +# +# Note: this test file is woefully incomplete. Right now there are +# only bits and pieces of tests. Please make this file more complete +# as you fix bugs and add features. + +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# LOCAL UTILITY PROCS +# proc getTroughSize {w} { if {[testConstraint testmetrics]} { @@ -48,9 +71,11 @@ proc getTroughSize {w} { } } -# XXX Note: this test file is woefully incomplete. Right now there are -# only bits and pieces of tests. Please make this file more complete -# as you fix bugs and add features. +# +# COMMON TEST SETUP +# +# For tests scrollbar-1.* +# foreach {width height} [wm minsize .] { set height [expr {($height < 200) ? 200 : $height}] @@ -62,6 +87,11 @@ pack .f -side left scrollbar .s pack .s -side right -fill y update + +# +# TESTS +# + set i 1 foreach test { {-activebackground #ff0000 #ff0000 non-existent @@ -105,7 +135,11 @@ foreach test { .s configure $name [lindex [.s configure $name] 3] } +# +# COMMON TEST CLEANUP +# destroy .s + test scrollbar-2.1 {Tk_ScrollbarCmd procedure} -returnCodes error -body { scrollbar } -result {wrong # args: should be "scrollbar pathName ?-option value ...?"} @@ -131,9 +165,14 @@ test scrollbar-2.5 {Tk_ScrollbarCmd procedure} -setup { destroy .s } -result .s + +# +# COMMON TEST SETUP +# scrollbar .s -orient vertical -highlightthickness 2 -bd 2 pack .s -side right -fill y update + test scrollbar-3.1 {ScrollbarWidgetCmd procedure} { list [catch {.s} msg] $msg } {1 {wrong # args: should be ".s option ?arg ...?"}} @@ -169,7 +208,12 @@ test scrollbar-3.9 {ScrollbarWidgetCmd procedure, "activate" option} { test scrollbar-3.10 {ScrollbarWidgetCmd procedure, "cget" option} { list [catch {.s cget -orient} msg] $msg } {0 vertical} + +# +# COMMON TEST SETUP +# scrollbar .s2 + test scrollbar-3.11 {ScrollbarWidgetCmd procedure, "cget" option} { expr {[.s2 cget -bd] == [lindex [.s2 configure -bd] 3]} } 1 @@ -188,7 +232,12 @@ test scrollbar-3.14 {ScrollbarWidgetCmd procedure, "cget" option} emptyTest { test scrollbar-3.14.1 {ScrollbarWidgetCmd procedure, "cget" option} emptyTest { # empty test; duplicated scrollbar-3.13 } {} + +# +# COMMON TEST CLEANUP +# destroy .s2 + test scrollbar-3.15 {ScrollbarWidgetCmd procedure, "configure" option} { llength [.s configure] } 20 @@ -282,6 +331,10 @@ test scrollbar-3.39 {ScrollbarWidgetCmd procedure, "fraction" option} {testmetri / ($height - 1 - [testmetrics cyvscroll .s]*2)}]]} } 1 +# +# COMMON TEST SETUP +# + toplevel .t -width 250 -height 100 wm geom .t +0+0 scrollbar .t.s -orient horizontal -borderwidth 2 @@ -291,22 +344,29 @@ update test scrollbar-3.41 {ScrollbarWidgetCmd procedure, "fraction" option} { format {%.6g} [.t.s fraction 100 0] } {0.5} -if {[testConstraint testmetrics]} { - # Only Windows has [testmetrics] - place configure .t.s -width [expr {2*[testmetrics cxhscroll .t.s]+1}] -} else { - if {[tk windowingsystem] eq "x11"} { - place configure .t.s -width [expr {[winfo height .t.s] - 2*([.t.s cget -highlightthickness] + [.t.s cget -bd] + 1)}] + +test scrollbar-3.42 {ScrollbarWidgetCmd procedure, "fraction" option} -setup { + if {[testConstraint testmetrics]} { + # Only Windows has [testmetrics] + place configure .t.s -width [expr {2*[testmetrics cxhscroll .t.s]+1}] } else { - # macOS aqua - place configure .t.s -width [expr {2*([.t.s cget -highlightthickness] + [.t.s cget -bd])}] + if {[tk windowingsystem] eq "x11"} { + place configure .t.s -width [expr {[winfo height .t.s] - 2*([.t.s cget -highlightthickness] + [.t.s cget -bd] + 1)}] + } else { + # macOS aqua + place configure .t.s -width [expr {2*([.t.s cget -highlightthickness] + [.t.s cget -bd])}] + } } -} -update -test scrollbar-3.42 {ScrollbarWidgetCmd procedure, "fraction" option} { + update +} -body { format {%.6g} [.t.s fraction 100 0] -} 0 +} -result 0 + +# +# COMMON TEST CLEANUP +# destroy .t + test scrollbar-3.43 {ScrollbarWidgetCmd procedure, "get" option} { list [catch {.s get a} msg] $msg } {1 {wrong # args: should be ".s get"}} @@ -422,6 +482,10 @@ test scrollbar-5.1 {ScrollbarCmdDeletedProc procedure} { list [info command .s?] [winfo exists .s1] } {{} 0} +# +# COMMON TEST SETUP +# + catch {destroy .s} scrollbar .s -orient vertical -relief sunken -bd 2 -highlightthickness 2 pack .s -side left -fill y @@ -558,6 +622,10 @@ test scrollbar-6.38 {ScrollbarPosition procedure} win { .s identify [expr {[winfo width .s] - 1}] 100 } {trough2} +# +# COMMON TEST SETUP +# + catch {destroy .t} toplevel .t -width 250 -height 150 wm geometry .t +0+0 @@ -606,9 +674,14 @@ test scrollbar-7.1 {EventuallyRedraw} { lappend result [.s cget -orient] } {horizontal vertical} +# +# COMMON TEST SETUP +# + catch {destroy .t} toplevel .t wm geometry .t +0+0 + test scrollbar-8.1 {TkScrollbarEventProc: recursive deletion} notAqua { # constrained by notAqua because this test clicks on an arrow of the # scrollbar - but macOS has no such arrows in modern scrollbars @@ -652,7 +725,9 @@ test scrollbar-8.2 {TkScrollbarEventProc: recursive deletion} notAqua { set result } {1 0 1} -set l [interp hidden] +# +# COMMON TEST CLEANUP +# deleteWindows test scrollbar-9.1 {scrollbar widget vs hidden commands} { @@ -661,7 +736,7 @@ test scrollbar-9.1 {scrollbar widget vs hidden commands} { interp hide {} .s destroy .s list [winfo children .] [interp hidden] -} [list {} $l] +} [list {} [interp hidden]] test scrollbar-10.1 {<MouseWheel> event on scrollbar} -setup { destroy .t .s @@ -747,9 +822,10 @@ test scrollbar-11.2 {bug fix: [011706ec42] Scrollbar unsafe wrt widget destructi destroy .top.s .top } -result {} +# +# TESTFILE CLEANUP +# + catch {destroy .s} catch {destroy .t} - -# cleanup cleanupTests -return diff --git a/tests/select.test b/tests/select.test index 661bd06..8eed35d 100644 --- a/tests/select.test +++ b/tests/select.test @@ -1,24 +1,39 @@ # This file is a Tcl script to test out Tk's selection management code, -# especially the "selection" command. It is organized in the standard fashion -# for Tcl tests. +# especially the "selection" command. # # Copyright © 1994 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. +# NOTE # -# Note: Multiple display selection handling will only be tested if the +# Multiple display selection handling will only be tested if the # environment variable TK_ALT_DISPLAY is set to an alternate display. + +# +# TESTFILE INITIALIZATION # -package require tcltest 2.2 -namespace import ::tcltest::* -eval tcltest::configure $argv -tcltest::loadTestedCommands +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import child select +# +# LOCAL TEST CONSTRAINTS +# + testConstraint cliboardManagerPresent 0 if {![catch {selection get -selection CLIPBOARD_MANAGER -type TARGETS}]} { if {"SAVE_TARGETS" in [selection get -selection CLIPBOARD_MANAGER -type TARGETS]} { @@ -26,6 +41,10 @@ if {![catch {selection get -selection CLIPBOARD_MANAGER -type TARGETS}]} { } } +# +# COMMON TEST SETUP +# + # Eliminate any existing selection on the screen. This is needed in case # there is a selection in some other application, in order to prevent races # from causing false errors in the tests below. @@ -39,7 +58,9 @@ foreach i {a b c d e f g j h i j k l m o p q r s t u v w x y z} { append longValue A$j B$j C$j D$j E$j F$j G$j H$j I$j K$j L$j M$j N$j } -# Now we start the main body of the test code +# +# TESTS +# test select-1.1 {Tk_CreateSelHandler procedure} -setup { selectionSetup @@ -268,7 +289,9 @@ test select-3.7 {Tk_OwnSelection procedure} -constraints x11 -setup { childTkProcess exit lappend result $lostSel } -result {{} . lost1} + # check reentrancy on selection replacement + test select-3.8 {Tk_OwnSelection procedure} -setup { selectionSetup } -body { @@ -282,7 +305,9 @@ test select-3.9 {Tk_OwnSelection procedure} -setup { selection own -selection CLIPBOARD -command { destroy .f2 } .f1 selection own -selection CLIPBOARD .f2 } -result {} + # multiple display tests + test select-3.10 {Tk_OwnSelection procedure} -constraints { altDisplay } -body { @@ -341,7 +366,9 @@ test select-4.4 {Tk_ClearSelection procedure} -constraints x11 -setup { childTkProcess exit lappend result [selection own] } -result {{} {}} + # multiple display tests + test select-4.5 {Tk_ClearSelection procedure} -constraints { altDisplay } -setup { @@ -472,7 +499,9 @@ test select-5.10 {Tk_GetSelection procedure} -constraints x11 -setup { childTkProcess exit lappend result $selInfo } -result {{selection owner didn't respond} {}} + # multiple display tests + test select-5.11 {Tk_GetSelection procedure} -constraints { altDisplay } -setup { @@ -629,7 +658,9 @@ test select-6.11 {Tk_SelectionCmd procedure} -setup { test select-6.12 {Tk_SelectionCmd procedure} -returnCodes error -body { selection clear foo bar } -result {wrong # args: should be "selection clear ?-option value ...?"} + # selection get + test select-6.13 {Tk_SelectionCmd procedure} -body { selection get -selection } -returnCodes error -result {value for "-selection" missing} @@ -682,8 +713,10 @@ test select-6.21 {Tk_SelectionCmd procedure} -setup { set selInfo "" list [selection get TEST] $selInfo } -result {{Test value} {TEST 0 4000}} + # selection handle # most of the handle section has been covered earlier + test select-6.22 {Tk_SelectionCmd procedure} -body { selection handle -selection } -returnCodes error -result {value for "-selection" missing} @@ -713,7 +746,9 @@ test select-6.29 {Tk_SelectionCmd procedure} -body { catch { destroy .f2 } selection handle .f2 dummy } -returnCodes error -result {bad window path name ".f2"} + # selection own + test select-6.30 {Tk_SelectionCmd procedure} -body { selection own -selection } -returnCodes error -result {value for "-selection" missing} @@ -866,6 +901,7 @@ test select-9.5 {SelCvtToX and SelCvtFromX procedures} -setup { # note, we are not testing MULTIPLE style selections # most control paths have been exercised above + test select-10.1 {ConvertSelection procedure, race with selection clear} -constraints { x11 } -setup { @@ -918,7 +954,9 @@ test select-10.3 {ConvertSelection procedure} -constraints x11 -setup { } -cleanup { childTkProcess exit } -result {PRIMARY selection doesn't exist or form "ERROR" not defined} + # testing timers + # This one hangs in Exceed test select-10.4 {ConvertSelection procedure} -constraints { x11 failsOnUbuntu @@ -1075,12 +1113,11 @@ test select-14.1 {Bug [73ba07efcd]: Use correct property type when handling MULT } -result {abcd} # -# CLEANUP +# TESTFILE CLEANUP # testutils forget child select cleanupTests -return # Local Variables: # mode: tcl diff --git a/tests/send.test b/tests/send.test index ee2ca74..66c8787 100644 --- a/tests/send.test +++ b/tests/send.test @@ -1,6 +1,5 @@ # This file is a Tcl script to test out the "send" command and the -# other procedures in the file tkSend.c. It is organized in the -# standard fashion for Tcl tests. +# other procedures in the file tkSend.c. # # Copyright © 1994 Sun Microsystems, Inc. # Copyright © 1994-1996 Sun Microsystems, Inc. @@ -10,15 +9,43 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2.2 -eval tcltest::configure $argv -tcltest::loadTestedCommands +# NOTE +# +# Under macOS/aqua, the send command works only with interpreters that exist in +# the same process. Tests in this test file that target an interpreter in another +# process carry a constraint "notAqua" so that they are skipped under macos/aqua. +# + +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import child +# +# LOCAL TEST CONSTRAINTS +# + testConstraint xhost [llength [auto_execok xhost]] +# +# COMMON TEST SETUP +# + set name [tk appname] set commId "" catch { @@ -29,6 +56,10 @@ tk appname tktest catch {send t_s_1 destroy .} catch {send t_s_2 destroy .} +# +# TESTS +# + test send-1.1 {RegOpen procedure, bogus property} {secureserver testsend} { testsend bogus set result [winfo interps] @@ -48,8 +79,13 @@ test send-1.3 {RegOpen procedure, bogus property} {secureserver testsend} { string range $x [string first " " $x] end } " tktest\nabcdefg\n" +# +# COMMON TEST SETUP +# + frame .f -width 1 -height 1 set id [string range [winfo id .f] 2 end] + test send-2.1 {RegFindName procedure} {secureserver testsend} { testsend prop root InterpRegistry {} list [catch {send foo bar} msg] $msg @@ -135,7 +171,13 @@ test send-5.4 {ValidateName procedure} {secureserver testsend} { winfo interps } {test} -if {[testConstraint nonPortable] && [testConstraint xhost]} { +# +# COMMON TEST SETUP +# +# For tests send-6.* +# + +if {[testConstraint nonPortable] && [testConstraint xhost] && [testConstraint notAqua]} { winfo interps tk appname tktest update @@ -146,20 +188,24 @@ if {[testConstraint nonPortable] && [testConstraint xhost]} { } } -test send-6.1 {ServerSecure procedure} {nonPortable secureserver} { +test send-6.1 {ServerSecure procedure} {nonPortable secureserver notAqua} { set a 44 list [childTkProcess eval [list send [tk appname] set a 55]] $a } {55 55} -test send-6.2 {ServerSecure procedure} {nonPortable secureserver xhost} { +test send-6.2 {ServerSecure procedure} {nonPortable secureserver xhost notAqua} { set a 22 exec xhost [exec hostname] list [catch {childTkProcess eval [list send [tk appname] set a 33]} msg] $a $msg } {0 22 {X server insecure (must use xauth-style authorization); command ignored}} -test send-6.3 {ServerSecure procedure} {nonPortable secureserver xhost} { +test send-6.3 {ServerSecure procedure} {nonPortable secureserver xhost notAqua} { set a abc exec xhost - [exec hostname] list [childTkProcess eval [list send [tk appname] set a new]] $a } {new new} + +# +# COMMON TEST CLEANUP +# childTkProcess exit test send-7.1 {Tk_SetAppName procedure} {secureserver testsend} { @@ -194,7 +240,7 @@ test send-8.1 {Tk_SendCmd procedure, options} {secureserver notAqua} { childTkProcess exit lappend result $a } {66 77} -test send-8.2 {Tk_SendCmd procedure, options} {secureserver altDisplay} { +test send-8.2 {Tk_SendCmd procedure, options} {secureserver altDisplay notAqua} { childTkProcess create -display $env(TK_ALT_DISPLAY) tk appname xyzgorp set a homeDisplay @@ -208,6 +254,7 @@ test send-8.2 {Tk_SendCmd procedure, options} {secureserver altDisplay} { childTkProcess exit set result } {altDisplay homeDisplay} + # Since macOS has no registry of interpreters, 8.3 and 8.10 will fail. test send-8.3 {Tk_SendCmd procedure, options} {secureserver notAqua} { list [catch {send -- -async foo bar baz} msg] $msg @@ -244,6 +291,10 @@ test send-8.10 {Tk_SendCmd procedure, no such interpreter} {secureserver notAqua list [catch {send bogus_name bogus_command} msg] $msg } {1 {no application named "bogus_name"}} +# +# COMMON TEST SETUP +# + catch { childTkInterp t_s_1 -class Test t_s_1 eval wm withdraw . @@ -264,13 +315,12 @@ test send-8.13 {Tk_SendCmd procedure, local execution, different interp} {secure send t_s_1 {set a them} list $a [send t_s_1 {set a}] } {us them} -test send-8.14 {Tk_SendCmd procedure, local interp killed by send} {secureserver testsend} { +test send-8.14 {Tk_SendCmd procedure, local interp killed by send} -constraints {secureserver testsend} -body { childTkInterp t_s_2 -class Test list [catch {send t_s_2 {destroy .; concat result}} msg] $msg -} {0 result} - -catch {interp delete t_s_2} - +} -cleanup { + catch {interp delete t_s_2} +} -result {0 result} test send-8.15 {Tk_SendCmd procedure, local interp, error info} {secureserver testsend failsOnUbuntu} { catch {error foo} list [catch {send t_s_1 {if 1 {open bogus_file_name}}} msg] $msg $errorInfo $errorCode @@ -289,9 +339,12 @@ test send-8.16 {Tk_SendCmd procedure, bogusCommWindow} {secureserver testsend fa set result } {1 {no application named "bogus"}} +# +# COMMON TEST CLEANUP +# catch {interp delete t_s_1} -test send-8.17 {Tk_SendCmd procedure, deferring events} {secureserver nonPortable} { +test send-8.17 {Tk_SendCmd procedure, deferring events} {secureserver nonPortable notAqua} { # Non-portable because some window managers ignore "raise" # requests so can't guarantee that new app's window won't # obscure .f, thereby masking the Expose event. @@ -311,7 +364,7 @@ test send-8.17 {Tk_SendCmd procedure, deferring events} {secureserver nonPortabl childTkProcess exit lappend result $a } {{no event yet} {no event yet} exposed} -test send-8.18 {Tk_SendCmd procedure, error in remote app} {secureserver} { +test send-8.18 {Tk_SendCmd procedure, error in remote app} {secureserver notAqua} { childTkProcess create set app [childTkProcess eval {tk appname}] set result [string tolower [list [catch {send $app open bad_name} msg] \ @@ -323,7 +376,7 @@ test send-8.18 {Tk_SendCmd procedure, error in remote app} {secureserver} { "open bad_name" invoked from within "send $app open bad_name"} {posix enoent {no such file or directory}}} -test send-8.19 {Tk_SendCmd, using modal timeouts} {secureserver} { +test send-8.19 {Tk_SendCmd, using modal timeouts} {secureserver notAqua} { childTkProcess create set app [childTkProcess eval {tk appname}] set x no @@ -336,6 +389,10 @@ test send-8.19 {Tk_SendCmd, using modal timeouts} {secureserver} { lappend result $x } {{x y z} no yes} +# +# COMMON TEST SETUP +# + tk appname tktest catch {destroy .f} frame .f @@ -357,6 +414,9 @@ test send-9.3 {Tk_GetInterpNames procedure} {secureserver testsend} { list [winfo interps] [testsend prop root InterpRegistry] } {{} {}} +# +# COMMON TEST SETUP +# catch {testsend prop root InterpRegistry "$commId tktest\n$id dummy\n"} test send-10.1 {SendEventProc procedure, bogus comm property} {secureserver testsend} { @@ -483,14 +543,14 @@ test send-10.17 {SendEventProc procedure, errorCode and errorInfo} {secureserver set errorInfo oldErrorInfo list [catch {send dummy foo} msg] $msg $errorInfo $errorCode } {4 {} oldErrorInfo oldErrorCode} -test send-10.18 {SendEventProc procedure, send kills application} {secureserver testsend} { +test send-10.18 {SendEventProc procedure, send kills application} {secureserver testsend notAqua} { childTkProcess create childTkProcess eval {tk appname t_s_3} set x [list [catch {send t_s_3 destroy .} msg] $msg] childTkProcess exit set x } {0 {}} -test send-10.19 {SendEventProc procedure, send exits} {secureserver testsend} { +test send-10.19 {SendEventProc procedure, send exits} {secureserver testsend notAqua} { childTkProcess create childTkProcess eval {tk appname t_s_3} set x [list [catch {send t_s_3 exit} msg] $msg] @@ -507,16 +567,27 @@ test send-11.2 {AppendPropCarefully and AppendErrorProc procedures} {secureserve update } {} +# +# COMMON TEST SETUP +# winfo interps tk appname tktest -catch {destroy .f} -frame .f -set id [string range [winfo id .f] 2 end] -test send-12.1 {TimeoutProc procedure} {secureserver testsend} { +test send-12.1 {TimeoutProc procedure} -constraints {secureserver testsend} -setup { + catch {destroy .f} + frame .f + set id [string range [winfo id .f] 2 end] +} -body { testsend prop root InterpRegistry "$id dummy\n" list [catch {send dummy foo} msg] $msg -} {1 {target application died or uses a Tk version before 4.0}} +} -cleanup { + unset id + destroy .f +} -result {1 {target application died or uses a Tk version before 4.0}} + +# +# COMMON TEST CLEANUP +# catch {testsend prop root InterpRegistry ""} @@ -536,16 +607,21 @@ test send-12.2 {TimeoutProc procedure} {secureserver notAqua} { set result } {1 {target application died}} -#macOS does not send to other processes +# +# COMMON TEST SETUP +# + winfo interps tk appname tktest -test send-13.1 {DeleteProc procedure} {secureserver notAqua} { + +#macOS does not send to other processes +test send-13.1 {DeleteProc procedure} -constraints {secureserver notAqua} -body { childTkProcess create set app [childTkProcess eval {rename send {}; tk appname}] set result [list [catch {send $app foo} msg] $msg [winfo interps]] childTkProcess exit set result -} {1 {no application named "tktest #2"} tktest} +} -result {1 {no application named "tktest[0-9]+"} tktest} -match regexp test send-13.2 {DeleteProc procedure} {secureserver notAqua} { winfo interps tk appname tktest @@ -556,7 +632,7 @@ test send-13.2 {DeleteProc procedure} {secureserver notAqua} { lappend result [winfo interps] [info commands send] } {{} {} foo send} -test send-14.1 {SendRestrictProc procedure, sends crossing from different displays} {secureserver altDisplay} { +test send-14.1 {SendRestrictProc procedure, sends crossing from different displays} {secureserver altDisplay notAqua} { childTkProcess create -display $env(TK_ALT_DISPLAY) set result [childTkProcess eval " toplevel .t -screen [winfo screen .] @@ -575,10 +651,15 @@ test send-14.1 {SendRestrictProc procedure, sends crossing from different displa set result } {child parent} +# +# COMMON TEST SETUP +# + catch { testsend prop root InterpRegister $registry tk appname tktest } + test send-15.1 {UpdateCommWindow procedure} {secureserver testsend} { set x [list [testsend prop comm TK_APPLICATION]] childTkInterp t_s_1 -class Test @@ -593,7 +674,7 @@ test send-15.1 {UpdateCommWindow procedure} {secureserver testsend} { } {tktest {t_s_2 t_s_1 tktest} {t_s_2 tktest} tktest} # -# CLEANUP +# TESTFILE CLEANUP # catch { @@ -604,4 +685,3 @@ catch { testutils forget child cleanupTests -return diff --git a/tests/spinbox.test b/tests/spinbox.test index cf72562..06cb479 100644 --- a/tests/spinbox.test +++ b/tests/spinbox.test @@ -1,24 +1,51 @@ -# This file is a Tcl script to test spinbox widgets in Tk. It is -# organized in the standard fashion for Tcl tests. +# This file is a Tcl script to test spinbox widgets in Tk. # # Copyright © 1994 The Regents of the University of California. # Copyright © 1994-1997 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -eval tcltest::configure $argv -tcltest::loadTestedCommands +# NOTE +# +# Collected comments about lacks from the test +# - Still need to write tests for SpinboxBlinkProc, SpinboxFocusProc, +# and SpinboxTextVarProc. +# - No tests for DisplaySpinbox. +# - Still need to write tests for SpinboxScanTo and SpinboxSelectTo. +# - No tests for EventuallyRedraw + +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import entry scroll +# +# COMMON TEST SETUP +# + foreach i {1 2 3} { set validateCmd$i [list validateCommand$i %W %d %i %P %s %S %v %V] } set cy [font metrics {Courier -12} -linespace] +# +# TESTS +# test spinbox-1.1 {configuration option: "activebackground"} -setup { spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ @@ -1043,9 +1070,9 @@ test spinbox-3.5 {SpinboxWidgetCmd procedure, "bbox" widget command} -setup { destroy .e } -result [list 5 5 0 $cy] -# Oryginaly the result was count using measurements -# and metrics. It was changed to less verbose solution - the result is the one -# that passes fonts constraint (this concerns tests 3.6, 3.7, 3.8, 3.10) +# Originally the result was counted using measurements and metrics. It was +# changed to less verbose solution - the result is the one that passes fonts +# constraint (this concerns tests 3.6, 3.7, 3.8, 3.10) test spinbox-3.6 {SpinboxWidgetCmd procedure, "bbox" widget command} -constraints { fonts } -setup { @@ -3123,8 +3150,6 @@ test spinbox-13.25 {GetSpinboxIndex procedure} -body { destroy .e } -result 21 -# XXX Still need to write tests for SpinboxScanTo and SpinboxSelectTo. - test spinbox-14.1 {SpinboxFetchSelection procedure} -body { spinbox .e .e insert end "This is a test string" @@ -3259,6 +3284,7 @@ test spinbox-18.1 {Spinbox widget vs hiding} -setup { # 19.* test cases in previous version highly depended on the previous # test cases. This was replaced by inserting recently set configurations # that matters for the test case + test spinbox-19.1 {spinbox widget validation} -setup { unset -nocomplain textVar validationData } -body { @@ -3889,22 +3915,13 @@ test spinbox-25.3 {Bugs [2a32225cd1] and [9fa3e08243]} -setup { destroy .s } -result {{A sample } text} -# Collected comments about lacks from the test -# XXX Still need to write tests for SpinboxBlinkProc, SpinboxFocusProc, -# and SpinboxTextVarProc. -# No tests for DisplaySpinbox. -# XXX Still need to write tests for SpinboxScanTo and SpinboxSelectTo. -# No tests for EventuallyRedraw - # -# CLEANUP +# TESTFILE CLEANUP # -# option clear foreach i {1 2 3} { unset validateCmd$i } unset i testutils forget entry scroll cleanupTests -return diff --git a/tests/systray.test b/tests/systray.test index 5a0d1c8..ef33067 100644 --- a/tests/systray.test +++ b/tests/systray.test @@ -1,18 +1,33 @@ # This file is a Tcl script to test systray and sysnotify features in Tk. -# It is organized in the standard fashion for Tcl tests. # # Copyright © 2020 Kevin Walzer/WordTech Communications LLC. # Copyright © 2020 Francois Vogel. # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -eval tcltest::configure $argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import child +# +# TESTS +# + test systray-1 {systray icon creation, all options} -setup { image create photo _book -data R0lGODlhDwAPAKIAAP//////AP8AAMDAwICAgAAAAAAAAAAAACwAAAAADwAPAAADSQhA2u5ksPeKABKSCaya29d4WKgERFF0l1IMQCAKatvBJ0OTdzzXI1xMB3TBZAvATtB6NSLKleXi3OBoLqrVgc0yv+DVSEUuFxIAOw== } -body { @@ -224,7 +239,7 @@ test sysnotify-2.2 {system notification is not linked to any systray icon on X11 } -result {} # -# CLEANUP +# TESTFILE CLEANUP # testutils forget child diff --git a/tests/testutils.GUIDE b/tests/testutils.GUIDE index 5125f5e..d789185 100644 --- a/tests/testutils.GUIDE +++ b/tests/testutils.GUIDE @@ -124,9 +124,8 @@ mechanism, whether debugging or improving it otherwise. B1. Files and file loading -------------------------- The entire testutils mechanism is implemented in a single file "testutils.tcl". -This file is sourced on behalf of each test file by a command in the file -"main.tcl", which in turn is loaded through the tcltest option "-loadfile" in -the file "all.tcl". +This file is sourced by the file "main.tcl", which in turn is sourced by +each testfile. B2. Importing procs and associated namespace variables ------------------------------------------------------ @@ -167,8 +166,8 @@ Note that the namespace variables "doneNess" and "seasonings" are initialized with a value, while the namespace variable "tasteVerdict" is not. Both variants of declaring/defining a namespace variable are supported. -B3. Tricky aspects of repeated initialization ---------------------------------------------- +B3. Tricky aspects of repeated initialization (in mode "-singleproc 1") +----------------------------------------------------------------------- While the entire Tk test suite is running, many test files are loaded, each of which may import and subsequently forget utility domains. When tracking a single utility domain across test files that come and go, associated namespace variables diff --git a/tests/testutils.tcl b/tests/testutils.tcl index 3eea930..adb32ef 100644 --- a/tests/testutils.tcl +++ b/tests/testutils.tcl @@ -141,6 +141,18 @@ namespace eval ::tk::test::generic { vwait [namespace current]::_pause($num) } + # resetWindows -- + # + # Restores a proper initial window setup for a test file, cleaning up from + # the state brought about by a previous testfile. + # + proc resetWindows {} { + deleteWindows + wm geometry . {} + raise . + update + } + # On macOS windows are not allowed to overlap the menubar at the top of the # screen or the dock. So tests which move a window and then check whether it # got moved to the requested location should use a y coordinate larger than the @@ -362,20 +374,29 @@ namespace eval ::tk::test::child { # childTkProcess -- # - # Create a new Tk application in a child process, and enable it to + # Create a new Tk application in a child process, and enable it to # evaluate scripts on our behalf. # # Suggestion: replace with child interp or thread ? # proc childTkProcess {subcmd args} { variable fd + variable interpCount switch -- $subcmd { create { if {[info exists fd] && [string length $fd]} { childTkProcess exit } + # Beware of bug #280189e35d. We prevent that bug by not relying + # on the automatic detection of duplicate interp names, as + # advertised by the manual page for "tk appname". Instead, we + # pass a unique appname to the executable that is being invoked + # below. + if {! [info exists interpCount]} { + set interpCount 1 + } set fd [open "|[list [::tcltest::interpreter] \ - -geometry +0+0 -name tktest] $args" r+] + -geometry +0+0 -name tktest[incr interpCount]] $args" r+] puts $fd "puts foo; flush stdout" flush $fd if {[gets $fd data] < 0} { @@ -627,7 +648,7 @@ namespace eval ::tk::test::dialog { variable testDialogFont variable iter_after variable testDialog; # On MS Windows, this variable is set at the C level - # by SetTestDialog() in tkWinDialog.c + # by SetTestDialog() in tkWinDialog.c switch -- $stage { launch { @@ -986,4 +1007,65 @@ namespace eval ::tk::test::text { testutils export } +namespace eval ::tk::test::timing { + + # init -- + # + # This is a reserved proc that is part of the mechanism that the proc + # testutils employs when making utility procs and associated namespace + # variables available to test files. + # + # Test authors should define and initialize namespace variables here if + # they need to be imported into the namespace in which tests are executing. + # This proc must not be exported. + # + # For more information, see the documentation in the file "testutils.GUIDE" + # + proc init {} { + variable dt + set dt(granularity) milliseconds + set dt(t0) [clock milliseconds] + } + + proc dt.get {} { + variable dt + set now [clock $dt(granularity)] + set result [expr {$now - $dt(t0)}] + set dt(t0) $now + return $result + } + + proc dt.reset {{granularity milliseconds}} { + if {$granularity ni "microseconds milliseconds seconds"} { + return -code error "invalid parameter \"$granularity\", expected \"microseconds\", \"milliseconds\" or \"seconds\"" + } + variable dt + set dt(granularity) $granularity + set dt(t0) [clock $dt(granularity)] + } + + # progress.* -- + # + # This set of procs monitors progress and total duration of a procedure + # in a loop. + # + # Derived from tests/ttk/ttk.test, see: + # + # https://core.tcl-lang.org/tk/file?ci=f94f84b254b0c5ad&name=tests/ttk/ttk.test&ln=335-340 + # + proc progress.init {{granularity milliseconds}} { + dt.reset $granularity + } + + proc progress.update {} { + puts -nonewline stderr "." ; flush stderr + } + + proc progress.end {} { + puts stderr " [dt.get] $::tk::test::timing::dt(granularity)" + } + + testutils export +} + # EOF diff --git a/tests/testutils.test b/tests/testutils.test index 747b0e2..c6fbc37 100644 --- a/tests/testutils.test +++ b/tests/testutils.test @@ -6,29 +6,40 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. # -package require tcltest 2.2 -eval tcltest::configure $argv -tcltest::loadTestedCommands - -# Notes: +# NOTE # -# - All tests have been constrained with test constraint "testutils". This -# constraint isn't set anywhere, and therefore false by default. Therefore, -# the tests in this file are skipped in a regular invocation of the Tk test -# suite. In order to run these test, you need to use the tcltest option -# "-constraints testutils" in the invocation, possibly combined with the -# option "-file testutils.test" to exclude other test files, or with -# "-limitconstraints true" to exclude other tests. +# All tests in this testfile have been constrained with test constraint "testutils". +# This constraint isn't set anywhere, and therefore false by default. Therefore, +# the tests in this file are skipped in a regular invocation of the Tk test suite. +# In order to run these test, you need to use the tcltest option +# "-constraints testutils" in the invocation, possibly combined with the option +# "-file testutils.test" to exclude other test files, or with +# "-limitconstraints true" to exclude other tests. + # -# - At this place in the test file, the file "testutils.tcl" has already been -# sourced (through tcltest::loadTestedCommands above), and the utility procs -# from domain "generic" are already available. Therefore we can make use of -# proc "assert" here. +# TESTFILE INITIALIZATION # +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows + assert {"testutils" in [info procs testutils]} # +# TESTS +# + +# # Section 1: invalid invocations # test testutils-1.1 {invalid subcommand} -constraints testutils -body { @@ -56,8 +67,10 @@ test testutils-1.6 {invalid domain for subCmd forget} -constraints testutils -bo } -result {testutils domain "foo" doesn't exist} -returnCodes error # -# Create a domain namespace for testing export, import, forget +# COMMON TEST SETUP # + +# Create a domain namespace for testing export, import, forget assert {"::tk::test::foo" ni [namespace children ::tk::test]} assert {"::tk::test::zez" ni [namespace children ::tk::test]} catch {rename init {}} @@ -74,7 +87,7 @@ namespace eval ::tk::test::foo { set initVars [info vars]; lappend initVars initVars # -# 2. Domain failures for forget and import +# Section 2. Domain failures for forget and import # test testutils-2.1 {forget not-imported domain} -constraints testutils -body { testutils forget foo @@ -88,7 +101,7 @@ test testutils-2.2 {duplicate import} -constraints testutils -body { } # -# 3. Import procs +# Section 3. Import procs # test testutils-3.1 {utility proc is imported and init proc is not} -constraints testutils -body { testutils import foo @@ -116,7 +129,7 @@ test testutils-3.3 {import fails: proc already exists} -constraints testutils -s } # -# 4. Import variables +# Section 4. Import variables # test testutils-4.1 {associated variables are imported} -constraints testutils -body { testutils import foo @@ -131,8 +144,9 @@ test testutils-4.1 {associated variables are imported} -constraints testutils -b } test testutils-4.2 { - Repeated initialization keeps imported variable defined without value non-existent, - even if a test file inadvertently assigns it a value in the meantime. + Repeated initialization keeps imported variable non-existent if it was + defined without a value, even if a test file inadvertently assigns it + a value in the meantime. } -constraints testutils -body { catch { testutils import foo @@ -161,8 +175,7 @@ test testutils-4.3 {import fails: variable already exists} -constraints testutil namespace delete ::zez } -test testutils-4.4 {repeated creation/deletion of requesting namespace doesn't fool testutils} -constraints testutils -setup { -} -body { +test testutils-4.4 {repeated creation/deletion of requesting namespace doesn't fool testutils} -constraints testutils -body { namespace eval ::zez { testutils import foo testutils forget foo @@ -178,7 +191,56 @@ test testutils-4.4 {repeated creation/deletion of requesting namespace doesn't f } # -# CLEANUP +# TESTS FOR SPECIFIC TESTUTILS DOMAINS +# + +# +# Domain "timing" +# + +# +# COMMON TEST SETUP +# +testutils import timing + +test dt-1.1 {Exercise a timing run, default granularity (milliseconds)} -constraints testutils -setup { +} -body { + dt.reset + expr {[dt.get] <= 1} +} -result 1 + +test dt-1.2 {Exercise granularity microseconds} -constraints testutils -body { + dt.reset microseconds + expr {[dt.get] <= 1000} +} -result 1 + +test dt-1.3 {Exercise granularity seconds} -constraints testutils -body { + dt.reset seconds + dt.get +} -result 0 + +test dt-1.4 {Invalid value for granularity} -constraints testutils -body { + dt.reset bogus +} -returnCodes error -result {invalid parameter "bogus", expected "microseconds", "milliseconds" or "seconds"} + +test progress-1.1 {Exercise a timing run for a loop, granularity microseconds} -constraints testutils -body { + progress.init microseconds + while {[incr i] < 10} { + progress.update + } + progress.end +} -errorOutput "......... * microseconds\n" -match glob -cleanup { + unset i +} + +# +# COMMON TEST CLEANUP +# +testutils forget timing + + +# +# TESTFILE CLEANUP # namespace delete ::tk::test::foo diff --git a/tests/text.test b/tests/text.test index a090656..55f4805 100644 --- a/tests/text.test +++ b/tests/text.test @@ -1,15 +1,30 @@ # This file is a Tcl script to test the code in the file tkText.c. -# This file is organized in the standard fashion for Tcl tests. # # Copyright © 1992-1994 The Regents of the University of California. # Copyright © 1994-1996 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -eval tcltest::configure $argv -tcltest::loadTestedCommands -namespace import -force tcltest::test +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# COMMON TEST SETUP +# # The statements below reset the main window; it's needed if the window # manager is mwm to make mwm forget about a previous minimum size setting. @@ -19,6 +34,10 @@ wm minsize . 1 1 wm positionfrom . user wm deiconify . +# +# TESTS +# + test text-1.1 {configuration option: "autoseparators"} -setup { text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} pack .t @@ -1175,6 +1194,7 @@ Line 7" } -cleanup { destroy .t } -returnCodes error -result {ambiguous option "co": must be bbox, cget, compare, configure, count, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, peer, pendingsync, replace, scan, search, see, sync, tag, window, xview, or yview} + # "configure" option is already covered above test text-7.1 {TextWidgetCmd procedure, "debug" option} -setup { @@ -3482,20 +3502,26 @@ test text-14.18 {ConfigureText procedure} -constraints fonts -setup { } -cleanup { destroy .top } -result {150x140+} -# This test was failing Windows because the title bar on .t was a certain -# minimum size and it was interfering with the size requested by the -setgrid. -# The "overrideredirect" gets rid of the titlebar so the toplevel can shrink -# to the appropriate size. + +# +# COMMON TEST SETUP +# + +# Tests text-14.19 and text-14.20 were failing on Windows because the title bar +# on .t was a certain minimum size and it was interfering with the size requested +# by the -setgrid. The "overrideredirect" gets rid of the titlebar so the +# toplevel can shrink to the appropriate size. # On macOS, however, there is no way to make the window overlap the -# menubar. Starting with macOS 15 (Sequoia) it became impossible for +# menubar. Starting with macOS 15 (Sequoia) it became impossible for # the y coordinate of the top of a window to be less than 10 plus the # menubar height (as reported by [[NSApp mainMenu] menuBarHeight]). - +# if {[tk windowingsystem] eq "aqua"} { set minY [expr [testmenubarheight] + 11] } else { set minY 0 } + test text-14.19 {ConfigureText procedure} -setup { toplevel .top text .top.t -font {Courier -12} -borderwidth 2 -highlightthickness 2 @@ -3509,11 +3535,6 @@ test text-14.19 {ConfigureText procedure} -setup { } -cleanup { destroy .top } -result "20x10+0+$minY" -# This test was failing on Windows because the title bar on .t was a certain -# minimum size and it was interfering with the size requested by the -setgrid. -# The "overrideredirect" gets rid of the titlebar so the toplevel can shrink -# to the appropriate size. -# On macOS we again use minY as a workaround. test text-14.20 {ConfigureText procedure} -setup { toplevel .top text .top.t -font {Courier -12} -borderwidth 2 -highlightthickness 2 @@ -7823,10 +7844,11 @@ test text-38.1 {Extending selection with mouse going outside the widget - Bug a9 destroy .t } -result {1.0} - -# cleanup +# +# TESTFILE CLEANUP +# + cleanupTests -return # Local Variables: # mode: tcl diff --git a/tests/textBTree.test b/tests/textBTree.test index 0f099a6..2c9c5a1 100644 --- a/tests/textBTree.test +++ b/tests/textBTree.test @@ -1,17 +1,32 @@ # This file is a Tcl script to test out the B-tree facilities of # Tk's text widget (the contents of the file "tkTextBTree.c". There are -# several file with additional tests for other features of text widgets. -# This file is organized in the standard fashion for Tcl tests. +# several files with additional tests for other features of text widgets. # # Copyright © 1992-1994 The Regents of the University of California. # Copyright © 1994 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -eval tcltest::configure $argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# LOCAL UTILITY PROCS +# proc setup {} { .t delete 1.0 100000.0 @@ -59,11 +74,19 @@ proc setupBig {} { .t debug 1 } -# Widget used in tests 1.* - 13.* +# +# COMMON TEST SETUP +# +# For tests 1.* - 13.* +# destroy .t text .t .t debug on +# +# TESTS +# + test btree-1.1 {basic insertions} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" @@ -901,8 +924,11 @@ test btree-13.8 {tag searching} -setup { .t tag add x 190.3 191.2 .t tag next x 3.5 } -result {190.3 191.2} -destroy .t +# +# COMMON TEST CLEANUP +# +destroy .t test btree-14.1 {check tag presence} -setup { destroy .t @@ -1305,9 +1331,8 @@ test btree-18.9 {tag search back, large complex btree spans} -setup { } -result {{500.0 520.0} {200.0 220.0}} # -# CLEANUP +# TESTFILE CLEANUP # rename setup {} cleanupTests -return diff --git a/tests/textDisp.test b/tests/textDisp.test index d5380b3..5fb0654 100644 --- a/tests/textDisp.test +++ b/tests/textDisp.test @@ -1,36 +1,43 @@ # This file is a Tcl script to test the code in the file tkTextDisp.c. -# This file is organized in the standard fashion for Tcl tests. # # Copyright © 1994 The Regents of the University of California. # Copyright © 1994-1997 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -eval tcltest::configure $argv -tcltest::loadTestedCommands -namespace import -force tcltest::test +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import scroll text -# The delay procedure needs to wait long enough for the asynchronous updates -# performed by the text widget to run. -proc delay {} { - update - after 100 - update -} - -# The procedure below is used to generate errors during scrolling commands. +# +# LOCAL UTILITY PROCS +# -proc scrollError args { - error "scrolling error" +proc bizarre_scroll args { + .t2.t delete 5.0 end } +# lequal -- +# # Return 1 if the two given lists are the same, otherwise return the two lists. # This is used to compare a test actual result with a test expected result. - +# proc lequal {res expected} { if {[llength $res] != [llength $expected]} { return [list "Lengths differ" result: $res - expected: $expected] @@ -43,6 +50,45 @@ proc lequal {res expected} { return 1 } +# delay -- +# +# Wait long enough for the asynchronous updates performed by the text widget to run. +# +proc delay {} { + update + after 100 + update +} + +# scrollError -- +# +# Generate errors during scrolling commands +# +proc scrollError args { + error "scrolling error" +} + +# xcharr -- +# +# Return x-coordinate in widget $w of the first pixel of $n-th char +# counted from the right, right justified +# +proc xcharr {n {w .t}} { + return [expr {[winfo width $w] - [bo $w] - [xw $n]}] +} + +# xe -- +# +# Return x-pixels of empty space in widget $w on a line containing $n chars +# +proc xe {n {w .t}} { + return [expr {[winfo width $w] - (2 * [bo $w]) - [xw $n]}] +} + +# +# COMMON TEST SETUP +# + # Create entries in the option database to be sure that geometry options # like border width have selected values. option add *Text.borderWidth 2 ; # tests work with [1-3] @@ -94,15 +140,6 @@ pack .t -expand 1 -fill both wm geometry . {} -# x-coordinate in widget $w of the first pixel of $n-th char counted from the right, right justified -proc xcharr {n {w .t}} { - return [expr {[winfo width $w] - [bo $w] - [xw $n]}] -} -# x-pixels of empty space in widget $w on a line containing $n chars -proc xe {n {w .t}} { - return [expr {[winfo width $w] - (2 * [bo $w]) - [xw $n]}] -} - # The statements below reset the main window; it's needed if the window # manager is mwm to make mwm forget about a previous minimum size setting. @@ -123,6 +160,10 @@ if {([winfo rooty .] < 50) || ([winfo rootx .] < 50)} { wm geom . +50+50 } +# +# TESTS +# + test textDisp-0.1 {double tag elide transition} { # Example from tkchat crash. For some reason can only # get this test case to crash when first. @@ -241,7 +282,12 @@ test textDisp-1.1 {GetStyle procedure, priorities and tab stops} { update idletasks lappend x [lindex [.t bbox 1.2] 0] } [list [expr {[bo]+70}] [expr {[bo]+50}] [expr {[bo]+50}]] + +# +# COMMON TEST CLEANUP +# .t tag delete x y z + test textDisp-1.2 {GetStyle procedure, wrapmode} { .t configure -wrap char .t delete 1.0 end @@ -258,6 +304,10 @@ test textDisp-1.2 {GetStyle procedure, wrapmode} { } [list [list [xchar 0] [yline 3] $fixedWidth $fixedHeight] \ [list [xchar 5] [yline 3] $fixedWidth $fixedHeight] \ {}] + +# +# COMMON TEST CLEANUP +# .t tag delete x y test textDisp-2.1 {LayoutDLine, basics} { @@ -314,9 +364,14 @@ test textDisp-2.7 {LayoutDLine, marks and tags} { } [list [list [xchar 2] [yline 1] $fixedWidth $fixedHeight] \ [list [xchar 5] [yline 1] $fixedWidth $fixedHeight] \ [list [xchar 11] [yline 1] $fixedWidth $fixedHeight]] + +# +# COMMON TEST CLEANUP +# foreach m [.t mark names] { catch {.t mark unset $m} } + test textDisp-2.8 {LayoutDLine, extra chunk at end of dline} -setup { scan [wm geom .] %dx%d width height } -body { @@ -447,8 +502,14 @@ test textDisp-2.18 {LayoutDLine, justification} { list [.t bbox 2.0] [.t bbox 3.0] } [list [list [expr {[bo]+[xe 4]/2-[xw 5]}] [yline 2] $fixedWidth $fixedHeight] \ [list [expr {[xcharr 10]-[xw 5]}] [yline 3] $fixedWidth $fixedHeight]] + +# +# COMMON TEST CLEANUP +# + .t tag delete x .t tag delete y + test textDisp-2.19 {LayoutDLine, margins} { .t configure -wrap word .t delete 1.0 end @@ -489,8 +550,14 @@ test textDisp-2.21 {LayoutDLine, margins} { } [list [list [expr {[bo]+80}] [yline 1] [expr {[xe 0]-80}] $fixedHeight] \ [list [expr {[bo]+80}] [yline 2] [expr {[xe 0]-80}] $fixedHeight] \ [list [expr {[bo]+80}] [yline 3] [expr {[xe 0]-80}] $fixedHeight]] + +# +# COMMON TEST CLEANUP +# + .t tag delete x .t tag delete y + test textDisp-2.22 {LayoutDLine, spacing options} { .t configure -wrap word .t delete 1.0 end @@ -517,7 +584,13 @@ test textDisp-2.22 {LayoutDLine, spacing options} { set b4 [expr {[lindex $i 1] + [lindex $i 4] - $b4}] list $b1 $b2 $b3 $b4 } [list 2 7 10 15] + +# +# COMMON TEST SETUP +# + .t configure -spacing1 0 -spacing2 0 -spacing3 0 + test textDisp-2.23 {LayoutDLine, spacing options} { .t configure -wrap word .t delete 1.0 end @@ -549,7 +622,13 @@ test textDisp-2.23 {LayoutDLine, spacing options} { set b4 [expr {[lindex $i 1] + [lindex $i 4] - $b4}] list $b1 $b2 $b3 $b4 } [list 1 5 13 16] + +# +# COMMON TEST SETUP +# + .t configure -spacing1 0 -spacing2 0 -spacing3 0 + test textDisp-2.24 {LayoutDLine, tabs, saving from first chunk} { .t delete 1.0 end .t tag delete x y @@ -626,6 +705,11 @@ test textDisp-3.1 {different character sizes} haveBigFontTwiceLargerThanTextFont [list [expr {[xchar 5]+[font measure $bigFont s]}] [yline 1] [font measure $bigFont a] $bigHeight] \ [list [bo] [yline 1] [expr {[xw 5]+[font measure $bigFont sampl]+[xw 2]}] $bigHeight $bigAscent] \ [list [bo] [expr {[bo]+2*$bigHeight+2*$fixedHeight}] [xw 5] $fixedHeight $fixedAscent]] + +# +# COMMON TEST SETUP +# + .t configure -wrap char test textDisp-4.1 {UpdateDisplayInfo, basic} { @@ -671,7 +755,12 @@ test textDisp-4.3 {UpdateDisplayInfo, tail of text line shifts} { [list [xchar 0] [yline 3] $fixedWidth $fixedHeight] \ [list [xchar 0] [yline 4] $fixedWidth $fixedHeight] \ {2.0 2.20}] + +# +# COMMON TEST CLEANUP +# .t mark unset x + test textDisp-4.4 {UpdateDisplayInfo, wrap-mode "none"} { .t configure -wrap none .t delete 1.0 end @@ -697,9 +786,15 @@ test textDisp-4.5 {UpdateDisplayInfo, tiny window} { {} \ [list [xchar 0] [yline 3] 1 $fixedHeight] \ {1.0 2.0 3.0}] + +# +# COMMON TEST SETUP +# + if {[tk windowingsystem] eq "win32"} { wm overrideredirect . 0 } + test textDisp-4.6 {UpdateDisplayInfo, tiny window} { # This test was failing on Windows because the title bar on . # was a certain minimum size and it was interfering with the size @@ -725,10 +820,16 @@ test textDisp-4.6 {UpdateDisplayInfo, tiny window} { set expected [list [list [xchar 0] [yline 1] 1 1] {} 1.0] lequal $x $expected } {1} + +# +# COMMON TEST SETUP +# + catch {destroy .f2} .t configure -borderwidth 0 -wrap char wm geom . {} update + test textDisp-4.7 {UpdateDisplayInfo, filling in extra vertical space} { # This test was failing on Windows because the title bar on . # was a certain minimum size and it was interfering with the size @@ -800,6 +901,11 @@ test textDisp-4.12 {UpdateDisplayInfo, filling in extra vertical space} { update winfo ismapped .b } 0 + +# +# COMMON TEST SETUP +# + .t configure -wrap word .t delete 1.0 end .t insert end "Line 1\nLine 2\nLine 3\nLine 4\nLine 5\nLine 6\nLine 7\n" @@ -807,6 +913,7 @@ test textDisp-4.12 {UpdateDisplayInfo, filling in extra vertical space} { .t insert end "Line 14\nLine 15\nLine 16" .t tag delete x .t tag configure x -relief raised -borderwidth 2 -background white + test textDisp-4.13 {UpdateDisplayInfo, special handling for top/bottom lines} { .t tag add x 1.0 end .t yview 1.0 @@ -923,7 +1030,7 @@ test textDisp-4.23 {UpdateDisplayInfo, no horizontal scrolling except for -wrap } [list [list [xchar 0] [yline 2] $fixedWidth $fixedHeight] \ [list [xchar 16] [yline 2] $fixedWidth $fixedHeight]] -test textDisp-5.1 {DisplayDLine, handling of spacing} { +test textDisp-5.1 {DisplayDLine, handling of spacing} -body { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "abcdefghijkl\nmnopqrstuvwzyz" @@ -940,11 +1047,12 @@ test textDisp-5.1 {DisplayDLine, handling of spacing} { update list [winfo geometry .t.f1] [winfo geometry .t.f2] \ [winfo geometry .t.f3] [winfo geometry .t.f4] -} [list 10x4+[xchar 3]+[expr {[yline 1]+8}] \ +} -cleanup { + .t tag delete spacing +} -result [list 10x4+[xchar 3]+[expr {[yline 1]+8}] \ 10x4+[expr {[xchar 6]+10}]+[expr {[yline 1]+8+($fixedHeight-4)/2}] \ 10x4+[xchar 1]+[expr {[yline 2]+8+2+8+($fixedHeight-4)}] \ 10x4+[expr {[xchar 9]+10}]+[expr {[yline 2]+8+2+8+($fixedAscent-4)}]] -.t tag delete spacing # Although the following test produces a useful result, its main # effect is to produce a core dump if Tk doesn't handle display @@ -958,7 +1066,12 @@ test textDisp-5.2 {DisplayDLine, line resizes during display} { list [winfo width .t.f] [winfo height .t.f] } [list 30 30] +# +# COMMON TEST SETUP +# + .t configure -wrap char + test textDisp-6.1 {scrolling in DisplayText, scroll up} { .t delete 1.0 end .t insert 1.0 "Line 1" @@ -1042,7 +1155,13 @@ test textDisp-6.6 {scrolling in DisplayText, Expose events after scroll} {aquaKn update list $tk_textRelayout $tk_textRedraw } {{1.0 9.0 10.0} {1.0 4.0 5.0 6.0 7.0 8.0 9.0 10.0}} + +# +# COMMON TEST SETUP +# + .t configure -bd 0 + test textDisp-6.7 {DisplayText, vertical scrollbar updates} { .t configure -wrap char .t delete 1.0 end @@ -1064,7 +1183,13 @@ test textDisp-6.8 {DisplayText, vertical scrollbar updates} { .t count -update -ypixels 1.0 end ; update set scrollInfo } [list 0.0 [expr {10.0/13}]] + +# +# COMMON TEST SETUP +# + .t configure -yscrollcommand {} -xscrollcommand setScrollInfo + test textDisp-6.9 {DisplayText, horizontal scrollbar updates} { .t configure -wrap none .t delete 1.0 end @@ -1104,6 +1229,9 @@ test textDisp-6.10 {DisplayText, redisplay embedded windows after scroll} {aqua} list $tk_textEmbWinDisplay } {{4.0 6.0}} +# +# COMMON TEST SETUP +# .t configure -bd 2 -relief raised -wrap char .t delete 1.0 end @@ -1111,6 +1239,7 @@ test textDisp-6.10 {DisplayText, redisplay embedded windows after scroll} {aqua} foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { .t insert end "\nLine $i" } + test textDisp-7.1 {TkTextRedrawRegion} {aquaKnownBug} { # constrained by aquaKnownBug until ticket [aad0231f07] is fixed frame .f2 -bg #ff0000 @@ -1190,6 +1319,11 @@ test textDisp-7.8 {TkTextRedrawRegion} {aquaKnownBug} { update list $tk_textRelayout $tk_textRedraw } {{} {borders 4.0 5.0 6.0 7.0 eof}} + +# +# COMMON TEST SETUP +# + .t configure -bd 0 test textDisp-8.1 {TkTextChanged: redisplay whole lines} { @@ -1204,7 +1338,13 @@ test textDisp-8.1 {TkTextChanged: redisplay whole lines} { update list $tk_textRelayout $tk_textRedraw [.t bbox 2.32] } [list {2.0 2.18 2.38} {2.0 2.18 2.38} [list [xchar 14] [yline 3] $fixedWidth $fixedHeight]] + +# +# COMMON TEST SETUP +# + .t configure -wrap char + test textDisp-8.2 {TkTextChanged, redisplay whole lines} { .t delete 1.0 end .t insert 1.0 "Line 1 is so long that it wraps around, two times" @@ -1550,9 +1690,13 @@ test textDisp-10.1 {TkTextRelayoutWindow} { update list $tk_textRelayout $tk_textRedraw } {{1.0 2.0 2.20 3.0 3.20 4.0} {borders 1.0 2.0 2.20 3.0 3.20 4.0 eof}} + +# +# COMMON TEST SETUP +# .t configure -bg [lindex [.t configure -bg] 3] -catch {destroy .top} -test textDisp-10.2 {TkTextRelayoutWindow} { + +test textDisp-10.2 {TkTextRelayoutWindow} -body { toplevel .top -width 300 -height 200 wm geometry .top +0+0 text .top.t -font $fixedFont -width 20 -height 10 -relief raised -bd 2 @@ -1563,8 +1707,13 @@ test textDisp-10.2 {TkTextRelayoutWindow} { place .top.t -width 150 -height 100 update .top.t index @0,0 -} {1.0} -catch {destroy .top} +} -result {1.0} -cleanup { + destroy .top +} + +# +# COMMON TEST SETUP +# .t delete 1.0 end .t insert end "Line 1" @@ -1572,6 +1721,7 @@ for {set i 2} {$i <= 200} {incr i} { .t insert end "\nLine $i" } update + test textDisp-11.1 {TkTextSetYView} { .t yview 30.0 update @@ -1663,7 +1813,12 @@ test textDisp-11.12 {TkTextSetYView, wrapped line is off-screen} { update list [.t index @0,0] $tk_textRedraw } {2.0 10.20} + +# +# COMMON TEST CLEANUP +# .t delete 10.0 11.0 + test textDisp-11.13 {TkTestSetYView, partially visible last line} { catch {destroy .top} toplevel .top @@ -1687,6 +1842,11 @@ test textDisp-11.13 {TkTestSetYView, partially visible last line} { # have changed, and the old '2.0 {5.0 6.0}' is quite wrong. list [.top.t index @0,0] $tk_textRedraw } {1.0 5.0} + +# +# COMMON TEST SETUP +# + catch {destroy .top} toplevel .top wm geometry .top +0+0 @@ -1697,6 +1857,7 @@ for {set i 2} {$i <= 20} {incr i} { .top.t insert end "\nLine $i" } update + test textDisp-11.14 {TkTextSetYView, only a few lines visible} { .top.t yview 5.0 update @@ -1808,9 +1969,14 @@ test textDisp-11.22 {TkTextSetYView, peer has -startline} { set res } {Line 5} +# +# COMMON TEST SETUP +# + .t configure -wrap word .t delete 50.0 51.0 .t insert 50.0 "This is a long line, one that will wrap around twice.\n" + test textDisp-12.1 {MeasureUp} { .t yview 100.0 update @@ -1832,7 +1998,13 @@ test textDisp-12.3 {MeasureUp} { update .t index @0,0 } {45.0} + +# +# COMMON TEST SETUP +# + .t configure -wrap none + test textDisp-12.4 {MeasureUp} { .t yview 100.0 update @@ -1848,6 +2020,10 @@ test textDisp-12.5 {MeasureUp} { .t index @0,0 } {45.0} +# +# COMMON TEST SETUP +# + .t configure -wrap none .t delete 1.0 end for {set i 1} {$i < 99} {incr i} { @@ -1855,6 +2031,7 @@ for {set i 1} {$i < 99} {incr i} { } .t insert end "Line 100" .t insert 30.end { is quite long, so that it flows way off the end of the window and we can use it to test out the horizontal positioning features of the "see" command.} + test textDisp-13.1 {TkTextSeeCmd procedure} { list [catch {.t see} msg] $msg } {1 {wrong # args: should be ".t see index"}} @@ -1989,9 +2166,14 @@ test textDisp-13.11 {TkTextSeeCmd procedure} {} { destroy .top2 set res } 0 -wm geom . {} +# +# COMMON TEST SETUP +# + +wm geom . {} .t configure -wrap none + test textDisp-14.1 {TkTextXviewCmd procedure} { .t delete 1.0 end update @@ -2001,16 +2183,20 @@ test textDisp-14.1 {TkTextXviewCmd procedure} { .t xview moveto .5 .t xview } [list 0.5 [expr {6./7.}]] -.t configure -wrap char -test textDisp-14.2 {TkTextXviewCmd procedure} { + +test textDisp-14.2 {TkTextXviewCmd procedure} -setup { + .t configure -wrap char +} -body { .t delete 1.0 end update .t insert end xxxxxxxxx\n .t insert end "xxxxx\n" .t insert end "xxxx" .t xview -} {0.0 1.0} -.t configure -wrap none +} -cleanup { + .t configure -wrap none +} -result {0.0 1.0} + test textDisp-14.3 {TkTextXviewCmd procedure} { .t delete 1.0 end update @@ -2096,6 +2282,10 @@ test textDisp-14.16 {TkTextXviewCmd procedure} { list [catch {.t xview flounder} msg] $msg } {1 {bad option "flounder": must be moveto or scroll}} +# +# COMMON TEST SETUP +# + .t configure -wrap char .t delete 1.0 end for {set i 1} {$i < 99} {incr i} { @@ -2104,6 +2294,7 @@ for {set i 1} {$i < 99} {incr i} { .t insert end "Line 100" .t delete 50.0 51.0 .t insert 50.0 "This is a long line, one that will wrap around twice.\n" + test textDisp-15.1 {ScrollByLines procedure, scrolling backwards} { .t yview 45.0 update @@ -2179,6 +2370,10 @@ test textDisp-15.8 {Scrolling near end of window} { set res } 1 +# +# COMMON TEST SETUP +# + .t configure -wrap char .t delete 1.0 end .t insert insert "Line 1" @@ -2196,6 +2391,7 @@ if {double(($totpix-5*$heightDiff)/$fixedHeight) != 206.0} { puts "---> Warning: the font actually used by the tests, which is \"[font actual [.t cget -font]]\",\ is too different from the requested \"[.t cget -font]\". Some of the upcoming tests will probably fail." } + test textDisp-16.1 {TkTextYviewCmd procedure} { .t yview 21.0 set x [.t yview] @@ -2538,12 +2734,17 @@ test textDisp-16.44 {TkTextYviewCmd procedure, scroll down, with elided lines} { .t index @0,0 } {2.0} +# +# COMMON TEST SETUP +# + .t delete 1.0 end foreach i {a b c d e f g h i j k l m n o p q r s t u v w x y z} { .t insert end "\nLine $i 11111 $i 22222 $i 33333 $i 44444 $i 55555" .t insert end " $i 66666 $i 77777 $i 88888 $i" } .t configure -wrap none + test textDisp-17.1 {TkTextScanCmd procedure} { list [catch {.t scan a b} msg] $msg } {1 {wrong # args: should be ".t scan mark x y" or ".t scan dragto x y ?gain?"}} @@ -2626,7 +2827,13 @@ test textDisp-17.9 {TkTextScanCmd procedure} { update lequal [.t index @0,0] $expected } {1} + +# +# COMMON TEST SETUP +# + .t configure -wrap word + test textDisp-17.10 {TkTextScanCmd procedure, word wrapping} { .t yview 10.0 update @@ -2641,6 +2848,11 @@ test textDisp-17.10 {TkTextScanCmd procedure, word wrapping} { update lequal [list $x [.t index @0,0]] $expected } {1} + +# +# COMMON TEST SETUP +# + .t configure -xscrollcommand setScrollInfo -yscrollcommand {} test textDisp-18.1 {GetXView procedure} { @@ -2740,10 +2952,15 @@ test textDisp-18.8 {GetXView procedure} { invoked from within "scrollError 0.0 1.0" (horizontal scrolling command executed by text)}} + +# +# COMMON TEST SETUP +# + catch {rename bgerror {}} catch {rename bogus {}} - .t configure -xscrollcommand {} -yscrollcommand setScrollInfo + test textDisp-19.1 {GetYView procedure} { .t configure -wrap char .t delete 1.0 end @@ -2922,7 +3139,12 @@ test textDisp-19.11.11 {TextWidgetCmd procedure, "count -displaylines"} { test textDisp-19.11.12 {TextWidgetCmd procedure, "count -displaylines"} { .t count -displaylines "16.0 +1displayline" "16.0 +2displaylines -1c" } 0 + +# +# COMMON TEST SETUP +# .t tag configure elide -elide 1 + test textDisp-19.11.13 {TextWidgetCmd procedure, "count -displaylines"} { .t tag remove elide 1.0 end .t tag add elide "16.0 +1displaylines" "16.0 +1displaylines +6c" @@ -3001,7 +3223,12 @@ test textDisp-19.11.23 {TextWidgetCmd procedure, "index +displaylines"} { [.t index "13.0 +2d lines"] [.t index "13.0 +3d lines"] \ [.t index "13.0 +4d lines"] } {16.23 16.44 16.39 16.57 16.39 16.60 16.77 16.79} + +# +# COMMON TEST CLEANUP +# .t tag remove elide 1.0 end + test textDisp-19.11.24 {TextWidgetCmd procedure, "index +/-displaylines"} { list [.t index "11.5 + -1 display lines"] \ [.t index "11.5 + +1 disp lines"] \ @@ -3011,7 +3238,7 @@ test textDisp-19.11.24 {TextWidgetCmd procedure, "index +/-displaylines"} { [.t index "11.5 +1 disp lines"] \ [.t index "11.5 +0 disp lines"] } {10.5 12.5 12.5 10.5 10.5 12.5 11.5} -.t tag remove elide 1.0 end + test textDisp-19.12 {GetYView procedure, partially visible last line} { catch {destroy .top} toplevel .top @@ -3040,7 +3267,12 @@ test textDisp-19.13 {GetYView procedure, partially visible last line} { update .top.t yview } [list 0.0 [expr {(5.0 * $fixedHeight - 3.0)/ (5.0 * $fixedHeight)}]] + +# +# COMMON TEST CLEANUP +# catch {destroy .top} + test textDisp-19.14 {GetYView procedure} { .t configure -wrap word .t delete 1.0 end @@ -3182,6 +3414,11 @@ test textDisp-19.19 {count -ypixels with indices in elided lines} { update set res [list [.t count -ypixels 5.0 11.0] [.t count -ypixels 5.0 11.20]] } [list [expr {1 * $fixedHeight}] [expr {2 * $fixedHeight}]] + +# +# COMMON TEST SETUP +# + .t delete 1.0 end .t insert end "Line 1" for {set i 2} {$i <= 200} {incr i} { @@ -3190,6 +3427,7 @@ for {set i 2} {$i <= 200} {incr i} { .t configure -wrap word .t delete 50.0 51.0 .t insert 50.0 "This is a long line, one that will wrap around twice.\n" + test textDisp-20.1 {FindDLine} { .t yview 48.0 list [.t dlineinfo 46.0] [.t dlineinfo 47.0] [.t dlineinfo 49.0] \ @@ -3220,23 +3458,32 @@ test textDisp-20.4 {FindDLine} { } [list [list [bo] [yline 9] [xw 20] $fixedHeight $fixedAscent] \ [list [bo] [yline 10] [xw 19] $fixedHeight $fixedAscent] \ {}] -.t config -wrap none -test textDisp-20.5 {FindDLine} { + +test textDisp-20.5 {FindDLine} -setup { + .t config -wrap none +} -body { .t yview 100.0 .t yview 48.0 list [.t dlineinfo 50.0] [.t dlineinfo 50.20] [.t dlineinfo 50.40] -} [list [list [bo] [yline 3] [xw 53] $fixedHeight $fixedAscent] \ - [list [bo] [yline 3] [xw 53] $fixedHeight $fixedAscent] \ - [list [bo] [yline 3] [xw 53] $fixedHeight $fixedAscent]] +} -cleanup { + .t config -wrap word +} -result [list [list [bo] [yline 3] [xw 53] $fixedHeight $fixedAscent] \ + [list [bo] [yline 3] [xw 53] $fixedHeight $fixedAscent] \ + [list [bo] [yline 3] [xw 53] $fixedHeight $fixedAscent]] -.t config -wrap word test textDisp-21.1 {TkTextPixelIndex} { .t yview 48.0 set off [expr {[bo]+3}] list [.t index @-10,-10] [.t index @$off,$off] [.t index @[expr {[xchar 2]+2}],$off] \ [.t index @[expr {[xchar 14]+1}],$off] [.t index @[xchar 5],[yline 5]] } {48.0 48.0 48.2 48.7 50.45} + +# +# COMMON TEST SETUP +# + .t insert end \n + test textDisp-21.2 {TkTextPixelIndex} { .t yview 195.0 set off [expr {[xchar 1]+1}] @@ -3280,6 +3527,10 @@ unset message set res } -1 +# +# COMMON TEST SETUP +# + .t delete 1.0 end .t insert end "Line 1" for {set i 2} {$i <= 200} {incr i} { @@ -3290,6 +3541,7 @@ for {set i 2} {$i <= 200} {incr i} { .t insert 50.0 "This is a long line, one that will wrap around twice.\n" update .t tag add x 50.1 + test textDisp-22.1 {TkTextCharBbox} { .t config -wrap word .t yview 48.0 @@ -3354,8 +3606,14 @@ test textDisp-22.6 {TkTextCharBbox, line visible but not char} haveBigFontTwiceL [list [xchar 2] [yline 11] [font measure $bigFont "n"] [expr {($height+3)-$oriHeight}]]] lequal [list [.t bbox 19.1] [.t bbox 20.1] [.t bbox 20.2]] $expected } {1} + +# +# COMMON TEST SETUP +# + wm geom . {} update + test textDisp-22.7 {TkTextCharBbox, different character sizes} haveBigFontTwiceLargerThanTextFont { .t config -wrap char .t yview 10.0 @@ -3364,7 +3622,12 @@ test textDisp-22.7 {TkTextCharBbox, different character sizes} haveBigFontTwiceL list [.t bbox 12.1] [.t bbox 12.2] } [list [list [xchar 1] [expr {[yline 3]+$ascentDiff}] $fixedWidth $fixedHeight] \ [list [xchar 2] [yline 3] [font measure $bigFont "n"] $bigHeight]] + +# +# COMMON TEST CLEANUP +# .t tag remove big 1.0 end + test textDisp-22.8 {TkTextCharBbox, horizontal scrolling} { .t configure -wrap none .t delete 1.0 end @@ -3379,7 +3642,7 @@ test textDisp-22.8 {TkTextCharBbox, horizontal scrolling} { [list [xchar 0] [yline 2] $fixedWidth $fixedHeight] \ [list [xchar 19] [yline 2] $fixedWidth $fixedHeight] \ {}] -test textDisp-22.9 {TkTextCharBbox, handling of spacing} { +test textDisp-22.9 {TkTextCharBbox, handling of spacing} -body { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "abcdefghijkl\nmnopqrstuvwzyz" @@ -3396,13 +3659,14 @@ test textDisp-22.9 {TkTextCharBbox, handling of spacing} { update list [.t bbox .t.f1] [.t bbox .t.f2] [.t bbox .t.f3] [.t bbox .t.f4] \ [.t bbox 1.1] [.t bbox 2.9] -} [list [list [xchar 3] [expr {[yline 1]+8}] 10 4] \ - [list [expr {[xchar 3]+10+[xw 3]}] [expr {[yline 1]+8+($fixedHeight-4)/2}] 10 4] \ - [list [xchar 1] [expr {[yline 2]+8+2+8+($fixedHeight-4)}] 10 4] \ - [list [expr {[xchar 1]+10+[xw 8]}] [expr {[yline 2]+8+2+8+($fixedAscent-4)}] 10 4] \ - [list [xchar 1] [expr {[yline 1]+8}] $fixedWidth $fixedHeight] \ - [list [expr {[xchar 1]+10+[xw 7]}] [expr {[yline 2]+8+2+8}] $fixedWidth $fixedHeight]] -.t tag delete spacing +} -cleanup { + .t tag delete spacing +} -result [list [list [xchar 3] [expr {[yline 1]+8}] 10 4] \ + [list [expr {[xchar 3]+10+[xw 3]}] [expr {[yline 1]+8+($fixedHeight-4)/2}] 10 4] \ + [list [xchar 1] [expr {[yline 2]+8+2+8+($fixedHeight-4)}] 10 4] \ + [list [expr {[xchar 1]+10+[xw 8]}] [expr {[yline 2]+8+2+8+($fixedAscent-4)}] 10 4] \ + [list [xchar 1] [expr {[yline 1]+8}] $fixedWidth $fixedHeight] \ + [list [expr {[xchar 1]+10+[xw 7]}] [expr {[yline 2]+8+2+8}] $fixedWidth $fixedHeight]] test textDisp-22.10 {TkTextCharBbox, handling of elided lines} { .t configure -wrap char .t delete 1.0 end @@ -3440,6 +3704,10 @@ test textDisp-22.11 {TkTextCharBbox, handling of wrapped elided lines} { [expr {[lindex [.t bbox 1.30] 0] - [lindex [.t bbox 2.5] 0]}] } [list 0 0] +# +# COMMON TEST SETUP +# + .t delete 1.0 end .t insert end "Line 1" for {set i 2} {$i <= 200} {incr i} { @@ -3449,6 +3717,7 @@ for {set i 2} {$i <= 200} {incr i} { .t delete 50.0 51.0 .t insert 50.0 "This is a long line, one that will wrap around twice.\n" update + test textDisp-23.1 {TkTextDLineInfo} { .t config -wrap word .t yview 48.0 @@ -3458,14 +3727,19 @@ test textDisp-23.1 {TkTextDLineInfo} { [list [bo] [yline 1] [xw 7] $fixedHeight $fixedAscent] \ [list [bo] [yline 5] [xw 13] $fixedHeight $fixedAscent] \ {}] + .t config -bd 4 -test textDisp-23.2 {TkTextDLineInfo} { + +test textDisp-23.2 {TkTextDLineInfo} -setup { + .t config -bd 4 +} -body { .t config -wrap word update .t yview 48.0 .t dlineinfo 50.40 -} [list [bo] [yline 5] [xw 13] $fixedHeight $fixedAscent] -.t config -bd 0 +} -cleanup { + .t config -bd 0 +} -result [list [bo] [yline 5] [xw 13] $fixedHeight $fixedAscent] test textDisp-23.3 {TkTextDLineInfo} { .t config -wrap none update @@ -3497,8 +3771,14 @@ test textDisp-23.5 {TkTextDLineInfo, cut-off lines} { [list [bo] [yline 11] [xw 7] [expr {($height+1)-$oriHeight}] $fixedAscent]] lequal [list [.t dlineinfo 19.0] [.t dlineinfo 20.0]] $expected } {1} + +# +# COMMON TEST SETUP +# + wm geom . {} update + test textDisp-23.6 {TkTextDLineInfo, horizontal scrolling} { .t config -wrap none .t delete 1.0 end @@ -3511,8 +3791,14 @@ test textDisp-23.6 {TkTextDLineInfo, horizontal scrolling} { } [list [list [expr {[xw -6]+[bo]}] [yline 1] [xw 10] $fixedHeight $fixedAscent] \ [list [expr {[xw -6]+[bo]}] [yline 2] [xw 52] $fixedHeight $fixedAscent] \ [list [expr {[xw -6]+[bo]}] [yline 3] [xw 5] $fixedHeight $fixedAscent]] + +# +# COMMON TEST SETUP +# + .t xview moveto 0 -test textDisp-23.7 {TkTextDLineInfo, centering} { + +test textDisp-23.7 {TkTextDLineInfo, centering} -body { .t config -wrap word .t delete 1.0 end .t insert end "First line\n" @@ -3523,10 +3809,11 @@ test textDisp-23.7 {TkTextDLineInfo, centering} { .t tag add x 1.0 .t tag add y 3.0 list [.t dlineinfo 1.0] [.t dlineinfo 2.0] [.t dlineinfo 3.0] -} [list [list [expr {[bo]+[xe 10]/2}] [yline 1] [xw 10] $fixedHeight $fixedAscent] \ +} -cleanup { + .t tag delete x y +} -result [list [list [expr {[bo]+[xe 10]/2}] [yline 1] [xw 10] $fixedHeight $fixedAscent] \ [list [bo] [yline 2] [xw 17] $fixedHeight $fixedAscent] \ [list [xcharr 5] [yline 5] [xw 5] $fixedHeight $fixedAscent]] -.t tag delete x y test textDisp-24.1 {TkTextCharLayoutProc} { .t configure -wrap char @@ -3670,8 +3957,14 @@ test textDisp-24.11 {TkTextCharLayoutProc, line ends with space that doesn't qui [list [xchar 0] [yline 2] $fixedWidth $fixedHeight] \ [list [expr {[xchar 20]+2}] [yline 1] 0 $fixedHeight] \ [list [xchar 0] [yline 2] $fixedWidth $fixedHeight]] + +# +# COMMON TEST SETUP +# + wm geom . {} update + test textDisp-24.12 {TkTextCharLayoutProc, tab causes wrap} { .t configure -wrap char .t delete 1.0 end @@ -3731,9 +4024,15 @@ test textDisp-24.16 {TkTextCharLayoutProc, no chars fit} { } [list [list [xchar 0] [yline 1] 1 $fixedHeight] \ [list [xchar 0] [yline 2] 1 $fixedHeight] \ [list [xchar 0] [yline 3] 1 $fixedHeight]] + +# +# COMMON TEST SETUP +# + if {[tk windowingsystem] eq "win32"} { wm overrideredirect . 0 } + test textDisp-24.17 {TkTextCharLayoutProc, -wrap word} { .t configure -wrap word .t delete 1.0 end @@ -3783,8 +4082,14 @@ test textDisp-24.20 {TkTextCharLayoutProc, vertical offset} { [list [bo] [yline 2] [xw 6] [expr {$fixedHeight+6}] [expr {$fixedAscent+6}]] \ [list [xchar 1] [expr {[yline 2]+2}] $fixedWidth $fixedHeight] \ [list [bo] [yline 2] [xw 6] [expr {$fixedHeight+2}] $fixedAscent]] + +# +# COMMON TEST SETUP +# + .t configure -width 30 update + test textDisp-24.21 {TkTextCharLayoutProc, word breaks} { .t configure -wrap word .t delete 1.0 end @@ -3812,9 +4117,15 @@ test textDisp-24.23 {TkTextCharLayoutProc, word breaks} { .t insert end "u vvvvv" .t bbox .t.f } [list [xchar 0] [yline 3] 50 20] + +# +# COMMON TEST SETUP +# + catch {destroy .t.f} .t configure -width 20 update + # Next test is currently constrained to not run on mac (aqua) because on # aqua it fails due to wrong implementation of tabs with right justification # (the text is not rendered at all). This is a bug. @@ -3840,9 +4151,14 @@ test textDisp-24.25 {TkTextCharLayoutProc, justification and tabs} -setup { destroy .tt } -result {1} +# +# COMMON TEST SETUP +# + .t configure -width 40 -bd 0 -relief flat -highlightthickness 0 \ -tabs 100 update + test textDisp-25.1 {CharBboxProc procedure, check tab width} { .t delete 1.0 end .t insert 1.0 abc\td\tfgh @@ -3851,9 +4167,14 @@ test textDisp-25.1 {CharBboxProc procedure, check tab width} { [list [expr {[bo]+100+$fixedWidth}] [yline 1] [expr {200-(100+$fixedWidth)}] $fixedHeight] \ [list [expr {[bo]+200}] [yline 1] $fixedWidth $fixedHeight]] +# +# COMMON TEST SETUP +# + .t configure -width 40 -bd 0 -relief flat -highlightthickness 0 -padx 0 -pady 0 \ -tabs {} update + test textDisp-26.1 {AdjustForTab procedure, no tabs} { .t delete 1.0 end .t insert 1.0 a\tbcdefghij\tc\td @@ -4036,9 +4357,14 @@ test textDisp-26.14.2 {AdjustForTab procedure, not enough space} { set res } [list [xchar 16] [xchar 8] [xchar 16] [xchar 8]] +# +# COMMON TEST SETUP +# + .t configure -width 20 -bd 2 -highlightthickness 2 -relief sunken -tabs {} \ -wrap char update + test textDisp-27.1 {SizeOfTab procedure, old-style tabs} { .t delete 1.0 end .t insert 1.0 a\tbcdefghij\tc\td @@ -4176,8 +4502,13 @@ test textDisp-27.7.2 {SizeOfTab procedure, fractional tab interpolation problem} expr {[lindex $res 0] - [lindex [.t bbox 1.20] 0]} } 0 +# +# COMMON TEST SETUP +# + .t configure -wrap char -tabs {} -width 20 update + test textDisp-27.8 {SizeOfTab procedure, right alignment} { .t delete 1.0 end .t insert 1.0 a\t\txyzzyabc @@ -4215,9 +4546,6 @@ test textDisp-27.11 {SizeOfTab procedure, making tabs at least as wide as a spac } [list [list [expr {round([bo]+17.14*$fixedWidth+$fixedWidth)}] [yline 1] [expr {[winfo width .t]-round([bo]+17.14*$fixedWidth+$fixedWidth)-[bo]}] $fixedHeight] \ [list [bo] [yline 2] $fixedWidth $fixedHeight]] -proc bizarre_scroll args { - .t2.t delete 5.0 end -} test textDisp-28.1 {"yview" option with bizarre scroll command} -setup { catch {destroy .t2} } -body { @@ -4452,8 +4780,12 @@ test textDisp-30.2 {elided text joining multiple logical lines} -setup { } -cleanup { destroy .t2 } -result {2} -catch {destroy .t2} +# +# COMMON TEST SETUP +# + +catch {destroy .t2} .t configure -height 1 update @@ -4803,7 +5135,6 @@ test textDisp-33.4 {one line longer than fits in the widget} { set idx [.tt index "1.0 + 1 displaylines"] set result } {ok} -destroy .tt test textDisp-33.5 {bold or italic fonts} win { destroy .tt pack [text .tt -wrap char -font {{MS Sans Serif} 15}] @@ -4826,6 +5157,10 @@ test textDisp-33.5 {bold or italic fonts} win { set result "italic font measurement ok" } } {italic font measurement ok} + +# +# COMMON TEST CLEANUP +# destroy .tt test textDisp-34.1 {Line heights recalculation problem: bug 2677890} -setup { @@ -4895,11 +5230,10 @@ test textDisp-36.1 {Display bug with 'yview insert'} -constraints {knownBug} -se } -result {} # -# CLEANUP +# TESTFILE CLEANUP # testutils forget scroll text deleteWindows option clear cleanupTests -return diff --git a/tests/textImage.test b/tests/textImage.test index b2befd9..bf8a2ee 100644 --- a/tests/textImage.test +++ b/tests/textImage.test @@ -1,28 +1,44 @@ # textImage.test -- test images embedded in text widgets # -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -eval tcltest::configure $argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import image imageInit +# +# COMMON TEST SETUP +# + # One time setup. Create a font to insure the tests are font metric invariant. destroy .t font create test_font -family courier -size 14 text .t -font test_font destroy .t +# +# TESTS +# + test textImage-1.1 {basic argument checking} -setup { destroy .t } -body { @@ -466,7 +482,7 @@ test textImage-5.1 {peer widget images} -setup { } -result {} # -# CLEANUP +# TESTFILE CLEANUP # destroy .t @@ -474,7 +490,6 @@ font delete test_font imageFinish testutils forget image cleanupTests -return # Local variables: # mode: tcl diff --git a/tests/textIndex.test b/tests/textIndex.test index 10ca7ad..2bfba73 100644 --- a/tests/textIndex.test +++ b/tests/textIndex.test @@ -1,17 +1,58 @@ # This file is a Tcl script to test the code in the file tkTextIndex.c. -# This file is organized in the standard fashion for Tcl tests. # # Copyright © 1994 The Regents of the University of California. # Copyright © 1994 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -eval tcltest::configure $argv -tcltest::loadTestedCommands -namespace import -force tcltest::test +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# Import utility procs for specific functional areas testutils import text +# +# LOCAL UTILITY PROCS +# + +proc getword index { + .t get [.t index "$index wordstart"] [.t index "$index wordend"] +} + +proc text_test_word {startend chars start} { + destroy .t + text .t + .t insert end $chars + if {[regexp {end} $start]} { + set start [.t index "${start}chars -2c"] + } else { + set start [.t index "1.0 + ${start}chars"] + } + if {[.t compare $start >= "end-1c"]} { + set start "end-2c" + } + set res [.t index "$start $startend"] + .t count 1.0 $res +} + +# +# COMMON TEST SETUP +# + catch {destroy .t} text .t -font {Courier -12} -width 20 -height 10 pack .t -expand 1 -fill both @@ -38,6 +79,10 @@ Line 7" image create photo textimage -width 10 -height 10 textimage put red -to 0 0 9 9 +# +# TESTS +# + test textIndex-1.1 {TkTextMakeByteIndex} {testtext} { # (lineIndex < 0) testtext .t byteindex -1 3 @@ -207,6 +252,10 @@ test textIndex-2.14 {TkTextMakeCharIndex: verify index is in range} { set x } 5.0 +# +# COMMON TEST SETUP +# + .t mark set foo 3.2 .t tag add x 2.8 2.11 .t tag add x 6.0 6.2 @@ -220,6 +269,7 @@ set weirdImage "foo-1" set weirdEmbWin ".t.bar-1" entry $weirdEmbWin .t window create 3.1 -window $weirdEmbWin + test textIndex-3.1 {TkTextGetIndex, weird mark names} { list [catch {.t index $weirdMark} msg] $msg } {0 4.0} @@ -238,6 +288,10 @@ test textIndex-3.5 {TkTextGetIndex, weird image names} { test textIndex-3.6 {TkTextGetIndex, weird image names} knownBug { list [catch {.t index "$weirdImage -1char"} msg] $msg } {0 2.0} + +# +# COMMON TEST CLEANUP +# .t delete 3.1 ; # remove the weirdEmbWin .t delete 2.1 ; # remove the weirdImage @@ -614,9 +668,6 @@ test textIndex-14.17 {TkTextIndexBackChars: UTF} { .t get {5.3 - 3 chars} } b -proc getword index { - .t get [.t index "$index wordstart"] [.t index "$index wordend"] -} test textIndex-15.1 {StartEnd} { list [catch {.t index {2.3 lineend}} msg] $msg } {0 2.13} @@ -653,7 +704,6 @@ test textIndex-15.11 {StartEnd} { test textIndex-15.12 {StartEnd} { getword 3.4 } 12345 -.t tag add x 2.8 2.11 test textIndex-15.13 {StartEnd} { list [catch {.t index {2.2 worde}} msg] $msg } {0 2.13} @@ -714,6 +764,10 @@ test textIndex-18.1 {Object indices don't cache mark names} { set res } {3.4 3.0 1.0} +# +# COMMON TEST SETUP +# + frame .f -width 100 -height 20 pack .f -side left @@ -844,22 +898,6 @@ test textIndex-19.14 {Display lines with elided lines} { set res [.t index "951.0 + 1 displaylines"] } {952.0} -proc text_test_word {startend chars start} { - destroy .t - text .t - .t insert end $chars - if {[regexp {end} $start]} { - set start [.t index "${start}chars -2c"] - } else { - set start [.t index "1.0 + ${start}chars"] - } - if {[.t compare $start >= "end-1c"]} { - set start "end-2c" - } - set res [.t index "$start $startend"] - .t count 1.0 $res -} - # Following tests copied from tests from string wordstart/end in Tcl test textIndex-21.4 {text index wordend} { @@ -1021,9 +1059,11 @@ test textIndex-26.2 {GetIndex errors out if mark, image, window, or tag is outsi } {1.0 {bad text index "mymark"} 1.0 {bad text index "redsquare"} 1.2\ {bad text index ".f"} 1.3 {text doesn't contain any characters tagged with "mytag"}} -# cleanup +# +# TESTFILE CLEANUP +# + rename textimage {} catch {destroy .t} testutils forget text cleanupTests -return diff --git a/tests/textMark.test b/tests/textMark.test index bbe839f..6f8aa59 100644 --- a/tests/textMark.test +++ b/tests/textMark.test @@ -1,15 +1,30 @@ # This file is a Tcl script to test the code in the file tkTextMark.c. -# This file is organized in the standard fashion for Tcl tests. # # Copyright © 1994 The Regents of the University of California. # Copyright © 1994 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -tcltest::configure {*}$argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# COMMON TEST SETUP +# destroy .t text .t -width 20 -height 10 @@ -36,6 +51,10 @@ wm minsize . 1 1 wm positionfrom . user wm deiconify . +# +# TESTS +# + test textMark-1.1 {TkTextMarkCmd - missing option} -returnCodes error -body { .t mark } -result {wrong # args: should be ".t mark option ?arg ...?"} @@ -305,12 +324,13 @@ test textMark-8.9 {MarkFindPrev - mark set in a text widget and retrieved from a lsort [list [.pt mark prev end] [.pt mark prev current] [.pt mark prev insert]] } -result {current insert mymark} +# +# TESTFILE CLEANUP +# + destroy .pt destroy .t - -# cleanup cleanupTests -return # Local Variables: # mode: tcl diff --git a/tests/textTag.test b/tests/textTag.test index f3677bd..9de3805 100644 --- a/tests/textTag.test +++ b/tests/textTag.test @@ -1,15 +1,30 @@ # This file is a Tcl script to test the code in the file tkTextTag.c. -# This file is organized in the standard fashion for Tcl tests. # # Copyright © 1994 The Regents of the University of California. # Copyright © 1994-1996 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -eval tcltest::configure $argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# COMMON TEST SETUP +# # # Don't use the variable name "fixedFont" since that variable is already defined @@ -51,6 +66,10 @@ bOy GIrl .#@? x_yz !@#$% Line 7" +# +# TESTS +# + test textTag-1.1 {tag configuration options} -body { .t tag configure x -background #012345 .t tag cget x -background @@ -615,7 +634,12 @@ test textTag-5.16a {TkTextTagCmd - "configure" option} -body { } -cleanup { .t tag delete x } -returnCodes error -result {unknown color name "rainbow"} + +# +# COMMON TEST CLEANUP +# .t tag delete x + test textTag-5.17 {TkTextTagCmd - "configure" option} -body { .t tag delete x .t tag configure x -spacing1 2 -spacing2 4 -spacing3 6 @@ -1175,7 +1199,12 @@ test textTag-14.1 {SortTags} -setup { } -cleanup { .t tag delete a b c d } -result {a b c d} + +# +# COMMON TEST CLEANUP +# .t tag delete a b c d + test textTag-14.2 {SortTags} -setup { .t tag delete a b c d } -body { @@ -1213,6 +1242,10 @@ test textTag-14.4 {SortTags} -setup { .t tag delete {*}[.t tag names] } -result {x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29} +# +# COMMON TEST SETUP +# + set c [.t bbox 2.1] set x1 [expr {[lindex $c 0] + [lindex $c 2]/2}] set y1 [expr {[lindex $c 1] + [lindex $c 3]/2}] @@ -1547,8 +1580,9 @@ test textTag-18.1 {TkTextPickCurrent tag bindings} -setup { destroy .t } -result {Enter {25 25 tag-Enter} {20 20 tag-Leave} {25 25 tag-Enter}} -destroy .t +# +# TESTFILE CLEANUP +# -# cleanup +destroy .t cleanupTests -return diff --git a/tests/textWind.test b/tests/textWind.test index 83d58c1..e9a1309 100644 --- a/tests/textWind.test +++ b/tests/textWind.test @@ -1,19 +1,34 @@ # This file is a Tcl script to test the code in the file tkTextWind.c. -# This file is organized in the standard fashion for Tcl tests. # # Copyright © 1994 The Regents of the University of California. # Copyright © 1994-1995 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -tcltest::configure {*}$argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import text +# +# COMMON TEST SETUP +# + deleteWindows # On Windows at least, the tests do work with {Courier -10}, {Courier -12} or {Courier -14} as fixedFont. @@ -62,7 +77,9 @@ wm deiconify . update -# ---------------------------------------------------------------------- +# +# TESTS +# test textWind-1.1 {basic tests of options} -setup { .t delete 1.0 end @@ -147,8 +164,13 @@ test textWind-1.6 {basic tests of options} -setup { 5x$fixedHeight+[xchar 2]+[yline 2] \ {-stretch {} {} 0 1}] +# +# COMMON TEST SETUP +# + .t delete 1.0 end .t insert end "This is the first line" + test textWind-2.1 {TkTextWindowCmd procedure} -body { .t window } -returnCodes error -result {wrong # args: should be ".t window option ?arg ...?"} @@ -304,7 +326,12 @@ test textWind-2.22 {TkTextWindowCmd procedure} -setup { } -body { .t window c } -returnCodes error -result {ambiguous window option "c": must be cget, configure, create, or names} + +# +# COMMON TEST CLEANUP +# destroy .f + test textWind-2.23 {TkTextWindowCmd procedure, "names" option} -setup { .t delete 1.0 end } -body { @@ -469,6 +496,10 @@ test textWind-3.11 {EmbWinConfigure procedure} -setup { .t index .t.b } -result {1.6} +# +# COMMON TEST SETUP +# + .t delete 1.0 end frame .f -width 10 -height 20 -bg $color .t window create 1.0 -window .f @@ -1645,10 +1676,9 @@ test textWind-18.3 {embedded window destruction in cascade} -setup { # -# CLEANUP +# TESTFILE CLEANUP # option clear testutils forget text cleanupTests -return diff --git a/tests/tk.test b/tests/tk.test index 4fdec1f..ee1a24a 100644 --- a/tests/tk.test +++ b/tests/tk.test @@ -1,26 +1,51 @@ -# This file is a Tcl script to test the tk command. -# It is organized in the standard fashion for Tcl tests. +# This file is a Tcl script to test the "tk" command, except those for +# "tk busy", which are in the test file busy.test. # # Copyright © 1997 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # Copyright © 2002 ActiveState Corporation. -package require tcltest 2.2 -eval tcltest::configure $argv -tcltest::loadTestedCommands -namespace import -force tcltest::test +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# LOCAL TEST CONSTRAINTS +# testConstraint testprintf [llength [info command testprintf]] +# +# TESTS +# + test tk-1.1 {tk command: general} -body { tk } -returnCodes error -result {wrong # args: should be "tk subcommand ?arg ...?"} test tk-1.2 {tk command: general} -body { tk xyz -} -returnCodes error -result {unknown or ambiguous subcommand "xyz": must be appname, busy, caret, fontchooser, inactive, print, scaling, sysnotify, systray, useinputmethods, or windowingsystem} +} -returnCodes error -result {unknown or ambiguous subcommand "xyz": must be appname, attribtable, busy, caret, fontchooser, inactive, print, scaling, sysnotify, systray, useinputmethods, or windowingsystem} + +# +# COMMON TEST SETUP +# # Value stored to restore default settings after 2.* tests set appname [tk appname] + test tk-2.1 {tk command: appname} -body { tk appname xyz abc } -returnCodes error -result {wrong # args: should be "tk appname ?newName?"} @@ -34,10 +59,19 @@ test tk-2.3 {tk command: appname} -constraints unix -body { test tk-2.4 {tk command: appname} -body { tk appname [tk appname] } -result [tk appname] + +# +# COMMON TEST CLEANUP +# tk appname $appname +# +# COMMON TEST SETUP +# + # Value stored to restore default settings after 3.* tests set scaling [tk scaling] + test tk-3.1 {tk command: scaling} -body { tk scaling -displayof } -returnCodes error -result {value for "-displayof" missing} @@ -81,10 +115,19 @@ test tk-3.11 {tk command: scaling: heightmm} -body { expr {int((25.4*[winfo screenheight .])/(72*1.25) + 0.5) \ - [winfo screenmmheight .]} } -result 0 + +# +# COMMON TEST CLEANUP +# tk scaling $scaling +# +# COMMON TEST SETUP +# + # Value stored to restore default settings after 4.* tests set useim [tk useinputmethods] + test tk-4.1 {tk command: useinputmethods} -body { tk useinputmethods -displayof } -returnCodes error -result {value for "-displayof" missing} @@ -183,8 +226,8 @@ test tk-8.1 {Test for ticket [1cc44617e2], see if TCL_LL_MODIFIER works as expec testprintf -21474836480 } -result {-21474836480 18446744052234715136} -# tests of [tk busy] in busy.test +# +# TESTFILE CLEANUP +# -# cleanup cleanupTests -return diff --git a/tests/ttk/all.tcl b/tests/ttk/all.tcl index 4d79948..e8e453e 100644 --- a/tests/ttk/all.tcl +++ b/tests/ttk/all.tcl @@ -1,7 +1,7 @@ # all.tcl -- # # This file contains a top-level script to run all of the ttk -# tests. Execute it by invoking "source all.tcl" when running tktest +# tests. Execute it by invoking "source all.tcl" when running tktest # in this directory. # # Copyright © 2007 the Tk developers. @@ -9,13 +9,49 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# REQUIREMENTS +# package require tk ;# This is the Tk test suite; fail early if no Tk! package require tcltest 2.2 -tcltest::configure {*}$argv -tcltest::configure -testdir [file normalize [file dirname [info script]]] -tcltest::configure -loadfile \ - [file join [file dirname [tcltest::testsDirectory]] main.tcl] + +# +# TCLTEST CONFIGURATION +# + +# Set defaults for the Tk test suite tcltest::configure -singleproc 1 -set ErrorOnFailures [info exists env(ERROR_ON_FAILURES)] -encoding system utf-8 -if {[tcltest::runAllTests] && $ErrorOnFailures} {exit 1} + +# Handle command line parameters +if {[llength $argv] & 1} { + puts stderr "error: the number of command line parameters must be even (name - value pairs)." + exit 1 +} +set ignoredOptions [list -testdir] +set ignoredIndices [list ] +set index 0 +foreach {key value} $argv { + if {$key in $ignoredOptions} { + lappend ignoredIndices $index + puts stderr "warning: the Tk test suite ignores the option \"$key\" on the command line." + } + incr index 2 +} +set tcltestOptions $argv +foreach index [lreverse $ignoredIndices] { + set tcltestOptions [lreplace $tcltestOptions $index [expr {$index + 1}]] +} +tcltest::configure {*}$tcltestOptions +unset ignoredIndices ignoredOptions index tcltestOptions + +# Set tcltest options that are not user-configurable for the Tk test suite +tcltest::configure -testdir [file normalize [file dirname [info script]]] + +# +# RUN ALL TESTS +# + +# Note: the environment variable ERROR_ON_FAILURES is set by Github CI +if {[tcltest::runAllTests] && [info exists env(ERROR_ON_FAILURES)]} { + exit 1 +} diff --git a/tests/ttk/checkbutton.test b/tests/ttk/checkbutton.test index d79b612..34a3992 100644 --- a/tests/ttk/checkbutton.test +++ b/tests/ttk/checkbutton.test @@ -2,10 +2,26 @@ # ttk::checkbutton widget tests. # -package require tk -package require tcltest 2.2 -namespace import -force tcltest::* -loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [file dirname [tcltest::configure -testdir]] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# TESTS +# test checkbutton-1.1 "Checkbutton check" -body { pack [ttk::checkbutton .cb -text "TCheckbutton" -variable cb] @@ -85,4 +101,8 @@ test checkbutton-2.2 "style command" -body { destroy .w } -result {customStyle.TCheckbutton customStyle.TCheckbutton TCheckbutton} +# +# TESTFILE CLEANUP +# + tcltest::cleanupTests diff --git a/tests/ttk/combobox.test b/tests/ttk/combobox.test index c38a78e..75302bb 100644 --- a/tests/ttk/combobox.test +++ b/tests/ttk/combobox.test @@ -2,10 +2,26 @@ # ttk::combobox widget tests # -package require tk -package require tcltest 2.2 -namespace import -force tcltest::* -loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [file dirname [tcltest::configure -testdir]] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# TESTS +# test combobox-1.0 "Combobox tests -- setup" -body { ttk::combobox .cb @@ -118,4 +134,8 @@ test combobox-4.2 "style command" -body { destroy .w } -result {customStyle.TCombobox customStyle.TCombobox TCombobox} +# +# TESTFILE CLEANUP +# + tcltest::cleanupTests diff --git a/tests/ttk/entry.test b/tests/ttk/entry.test index 099eb5f..0a68d3e 100644 --- a/tests/ttk/entry.test +++ b/tests/ttk/entry.test @@ -1,15 +1,30 @@ # -# Tile package: entry widget tests +# ttk::entry widget tests # -package require tk -package require tcltest 2.2 -namespace import -force tcltest::* -loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script "main.tcl", which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [file dirname [tcltest::configure -testdir]] main.tcl] +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import entry scroll +# +# LOCAL UTILITY PROCS +# + # Some of the tests raise background errors; # override default bgerror to catch them. # @@ -21,6 +36,9 @@ proc bgerror {error} { } # +# TESTS +# + test entry-1.1 "Create entry widget" -body { ttk::entry .e } -result .e @@ -401,7 +419,7 @@ test entry-12.2 "style command" -body { } -result {customStyle.TEntry customStyle.TEntry TEntry} # -# CLEANUP +# TESTFILE CLEANUP # testutils forget entry scroll diff --git a/tests/ttk/image.test b/tests/ttk/image.test index 8d58a12..4229827 100644 --- a/tests/ttk/image.test +++ b/tests/ttk/image.test @@ -1,7 +1,27 @@ -package require tk -package require tcltest 2.2 -namespace import -force tcltest::* -loadTestedCommands +# +# Tests for images in various ttk widgets +# + +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [file dirname [tcltest::configure -testdir]] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# TESTS +# test image-1.1 "Bad image element" -body { ttk::style element create BadImage image badimage @@ -48,4 +68,7 @@ test image-2.2 "Deletion of displayed image (radiobutton)" -setup { } -result {} # +# TESTFILE CLEANUP +# + tcltest::cleanupTests diff --git a/tests/ttk/labelframe.test b/tests/ttk/labelframe.test index b82d2c3..792817e 100644 --- a/tests/ttk/labelframe.test +++ b/tests/ttk/labelframe.test @@ -1,7 +1,27 @@ -package require tk -package require tcltest 2.2 -namespace import -force tcltest::* -loadTestedCommands +# +# ttk::labelframe widget tests +# + +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [file dirname [tcltest::configure -testdir]] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# TESTS +# test labelframe-1.0 "Setup" -body { pack [ttk::labelframe .lf] -expand true -fill both @@ -142,4 +162,8 @@ test labelframe-7.2 "style command" -body { destroy .w } -result {customStyle.TLabelframe customStyle.TLabelframe TLabelframe} +# +# TESTFILE CLEANUP +# + tcltest::cleanupTests diff --git a/tests/ttk/layout.test b/tests/ttk/layout.test index 31ef1f5..e0baa20 100644 --- a/tests/ttk/layout.test +++ b/tests/ttk/layout.test @@ -1,7 +1,27 @@ -package require tk -package require tcltest 2.2 -namespace import -force tcltest::* -loadTestedCommands +# +# Tests for the "ttk::style layout" command +# + +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [file dirname [tcltest::configure -testdir]] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# TESTS +# test layout-1.1 "Size computations for mixed-orientation layouts" -body { ttk::style theme use default @@ -26,4 +46,8 @@ test layout-2 "Empty -children not allowed" -body { ttk::style layout Test.Tentry {Entry.field -children {}} } -returnCodes error -result {Invalid -children value} +# +# TESTFILE CLEANUP +# + tcltest::cleanupTests diff --git a/tests/ttk/notebook.test b/tests/ttk/notebook.test index b94fac1..f9421ce 100644 --- a/tests/ttk/notebook.test +++ b/tests/ttk/notebook.test @@ -1,7 +1,33 @@ -package require tk -package require tcltest 2.2 -namespace import -force tcltest::* -loadTestedCommands +# +# ttk::notebook widget tests +# + +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [file dirname [tcltest::configure -testdir]] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# LOCAL UTILITY PROCS +# + +proc inoperative {args} {} + +# +# TESTS +# test notebook-1.0 "Setup" -body { ttk::notebook .nb @@ -14,7 +40,6 @@ test notebook-1.1 "Cannot add ancestor" -body { .nb add . } -returnCodes error -result "*" -match glob -proc inoperative {args} {} inoperative test notebook-1.2 "Cannot add siblings" -body { # This is legal now @@ -342,9 +367,13 @@ test notebook-6.12 "Hide and re-add a tab" -setup { } -result [list 1 normal 2 hidden 2 normal] # -# Insert: +# COMMON TEST CLEANUP # unset nb + +# +# Insert: +# test notebook-7.0 "insert - setup" -body { pack [ttk::notebook .nb] for {set i 0} {$i < 5} {incr i} { @@ -577,4 +606,8 @@ test notebook-9.2 "move first tab to last position by numerical index" -body { destroy .n } -result {Managed window index "3" out of bounds} -returnCodes error +# +# TESTFILE CLEANUP +# + tcltest::cleanupTests diff --git a/tests/ttk/panedwindow.test b/tests/ttk/panedwindow.test index 149f972..f33d8bb 100644 --- a/tests/ttk/panedwindow.test +++ b/tests/ttk/panedwindow.test @@ -1,10 +1,58 @@ -package require tk -package require tcltest 2.2 -namespace import -force tcltest::* -loadTestedCommands +# +# ttk::panedwindow widget tests +# + +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [file dirname [tcltest::configure -testdir]] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# LOCAL UTILITY PROCS +# + +# checkorder -- +# Ensure that Y coordinates windows in $winlist are strictly increasing. +# +proc checkorder {winlist} { + set pos -1 + set positions [list] + foreach win $winlist { + lappend positions [set nextpos [winfo y $win]] + if {$nextpos <= $pos} { + error "window $win out of order ($positions)" + } + set pos $nextpos + } +} proc propagate-geometry {} { update idletasks } +proc sashpositions {pw} { + set positions [list] + set npanes [llength [winfo children $pw]] + for {set i 0} {$i < $npanes - 1} {incr i} { + lappend positions [$pw sashpos $i] + } + return $positions +} + +# +# TESTS +# + # Basic sanity checks: # test panedwindow-1.0 "Setup" -body { @@ -122,9 +170,6 @@ test panedwindow-2.3 "..., cont'd" -body { test panedwindow-2.end "Cleanup" -body { destroy .pw } -# -# ... -# test panedwindow-3.0 "configure pane" -body { ttk::panedwindow .pw .pw add [listbox .pw.lb1] @@ -165,21 +210,6 @@ test panedwindow-4.2 "forget forgotten" -body { .pw forget .pw.l1 } -returnCodes error -result ".pw.l1 is not managed by .pw" -# checkorder $winlist -- -# Ensure that Y coordinates windows in $winlist are strictly increasing. -# -proc checkorder {winlist} { - set pos -1 - set positions [list] - foreach win $winlist { - lappend positions [set nextpos [winfo y $win]] - if {$nextpos <= $pos} { - error "window $win out of order ($positions)" - } - set pos $nextpos - } -} - test panedwindow-4.3 "insert command" -body { .pw insert end .pw.l1 .pw insert end .pw.l3 @@ -215,14 +245,6 @@ test panedwindow-5.1 "Propagate Map/Unmap state to children" -body { ### sashpos tests. # -proc sashpositions {pw} { - set positions [list] - set npanes [llength [winfo children $pw]] - for {set i 0} {$i < $npanes - 1} {incr i} { - lappend positions [$pw sashpos $i] - } - return $positions -} test paned-sashpos-setup "Setup for sash position test" -body { ttk::style theme use default @@ -323,4 +345,8 @@ test panedwindow-6.2 "style command" -body { destroy .w } -result {customStyle.TPanedwindow customStyle.TPanedwindow TPanedwindow} +# +# TESTFILE CLEANUP +# + tcltest::cleanupTests diff --git a/tests/ttk/progressbar.test b/tests/ttk/progressbar.test index b3f1dc6..a70e742 100644 --- a/tests/ttk/progressbar.test +++ b/tests/ttk/progressbar.test @@ -1,8 +1,27 @@ -package require tk -package require tcltest 2.2 -namespace import -force tcltest::* -loadTestedCommands +# +# ttk::progressbar widget tests +# +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [file dirname [tcltest::configure -testdir]] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# TESTS +# test progressbar-1.1 "Setup" -body { ttk::progressbar .pb @@ -160,4 +179,8 @@ test progressbar-4.2 "style command" -body { destroy .w } -result {customStyle.Vertical.TProgressbar Vertical.customStyle.Vertical.TProgressbar TProgressbar} +# +# TESTFILE CLEANUP +# + tcltest::cleanupTests diff --git a/tests/ttk/radiobutton.test b/tests/ttk/radiobutton.test index 29321c7..b69a063 100644 --- a/tests/ttk/radiobutton.test +++ b/tests/ttk/radiobutton.test @@ -2,10 +2,26 @@ # ttk::radiobutton widget tests. # -package require tk -package require tcltest 2.2 -namespace import -force tcltest::* -loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [file dirname [tcltest::configure -testdir]] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# TESTS +# test radiobutton-1.1 "Radiobutton check" -body { pack \ @@ -60,4 +76,8 @@ test radiobutton-2.2 "style command" -body { destroy .w } -result {customStyle.TRadiobutton customStyle.TRadiobutton TRadiobutton} +# +# TESTFILE CLEANUP +# + tcltest::cleanupTests diff --git a/tests/ttk/scale.test b/tests/ttk/scale.test index ecda7d5..32db3cf 100644 --- a/tests/ttk/scale.test +++ b/tests/ttk/scale.test @@ -1,7 +1,27 @@ -package require tk -package require tcltest 2.2 -namespace import -force tcltest::* -loadTestedCommands +# +# ttk::scale widget tests +# + +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [file dirname [tcltest::configure -testdir]] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# TESTS +# test scale-1.0 "Self-destruction" -body { trace add variable v write { destroy .s ;# } @@ -49,5 +69,9 @@ test scale-3.2 "style command" -body { destroy .w } -result {customStyle.Vertical.TScale Vertical.customStyle.Vertical.TScale TScale} +# +# TESTFILE CLEANUP +# + tcltest::cleanupTests diff --git a/tests/ttk/scrollbar.test b/tests/ttk/scrollbar.test index e1bae69..83ed31a 100644 --- a/tests/ttk/scrollbar.test +++ b/tests/ttk/scrollbar.test @@ -1,8 +1,9 @@ -package require tk -package require tcltest 2.2 -namespace import -force tcltest::* -loadTestedCommands +# +# ttk::scrollbar widget tests +# +# NOTE +# # Before 2019 the code in library/ttk/scrollbar.tcl would replace the # constructor of ttk::scrollbar with the constructor of tk::scrollbar # unless the -class or -style options were specified.. @@ -11,6 +12,27 @@ loadTestedCommands # test was changed to expect the class to be TScrollbar instead of # Scrollbar. +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [file dirname [tcltest::configure -testdir]] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# TESTS +# + test scrollbar-swapout-1 "Don't use core scrollbars on OSX..." \ -constraints { aqua @@ -132,5 +154,8 @@ test scrollbar-11.2 "style command" -body { destroy .w } -result {customStyle.Horizontal.TScrollbar Horizontal.customStyle.Horizontal.TScrollbar TScrollbar} -tcltest::cleanupTests +# +# TESTFILE CLEANUP +# +tcltest::cleanupTests diff --git a/tests/ttk/spinbox.test b/tests/ttk/spinbox.test index 030a344..36ab3df 100644 --- a/tests/ttk/spinbox.test +++ b/tests/ttk/spinbox.test @@ -2,10 +2,26 @@ # ttk::spinbox widget tests # -package require tk -package require tcltest 2.2 -namespace import -force tcltest::* -loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [file dirname [tcltest::configure -testdir]] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# TESTS +# test spinbox-1.0 "Spinbox tests -- setup" -body { ttk::spinbox .sb @@ -397,6 +413,10 @@ test spinbox-5.2 "style command" -body { destroy .w } -result {customStyle.TSpinbox customStyle.TSpinbox TSpinbox} +# +# TESTFILE CLEANUP +# + tcltest::cleanupTests # Local variables: diff --git a/tests/ttk/toggleswitch.test b/tests/ttk/toggleswitch.test new file mode 100644 index 0000000..118b97d --- /dev/null +++ b/tests/ttk/toggleswitch.test @@ -0,0 +1,139 @@ +# +# ttk::toggleswitch widget tests +# + +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed for "-singleproc 0" + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [file dirname [tcltest::configure -testdir]] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# TESTS +# + +test toggleswitch-1.1 "Toggleswitch" -body { + pack [ttk::toggleswitch .sw -variable sw] +} + +test toggleswitch-1.2 "Toggleswitch toggle" -body { + .sw toggle + list [set sw] [.sw instate selected] [expr {[.sw get] == [.sw get max]}] +} -result [list 1 1 1] + +test toggleswitch-1.3 "Toggleswitch switchstate" -body { + .sw switchstate 0 + list [set sw] [.sw instate selected] [expr {[.sw get] == [.sw get min]}] +} -result [list 0 0 1] + +test toggleswitch-1.4 "Toggleswitch variable" -body { + set result [list] + set sw 1 + lappend result [.sw instate selected] [expr {[.sw get] == [.sw get max]}] + set sw 0 + lappend result [.sw instate selected] [expr {[.sw get] == [.sw get min]}] +} -result {1 1 0 1} + +test toggleswitch-1.5 "Unset toggleswitch variable" -body { + set result [list] + unset sw + lappend result [.sw instate invalid] [info exists sw] + set sw 1 + lappend result [.sw instate invalid] [info exists sw] +} -cleanup { + destroy .sw +} -result {1 0 0 1} + +test toggleswitch-1.6 "Toggleswitch default variable" -body { + set result [list] + ttk::toggleswitch .sw -onvalue on -offvalue off + lappend result [.sw cget -variable] [info exists .sw] [.sw state] + .sw toggle + lappend result [info exists .sw] [set .sw] [.sw state] + .sw toggle + lappend result [info exists .sw] [set .sw] [.sw state] +} -cleanup { + destroy .sw +} -result [list .sw 0 invalid 1 on selected 1 off {}] + +test toggleswitch-1.7 "Toggleswitch empty variable" -body { + # shall simply not crash + ttk::toggleswitch .sw -variable {} + .sw toggle +} -cleanup { + destroy .sw +} -result {} + +test toggleswitch-2.1 "-size option" -body { + ttk::toggleswitch .sw -size 1 + set w1 [winfo reqwidth .sw]; set h1 [winfo reqheight .sw] + .sw configure -size 2 + set w2 [winfo reqwidth .sw]; set h2 [winfo reqheight .sw] + .sw configure -size 3 + set w3 [winfo reqwidth .sw]; set h3 [winfo reqheight .sw] + list [expr {$w1 < $w2 && $h1 < $h2}] [expr {$w2 < $w3 && $h2 < $h3}] +} -cleanup { + destroy .sw +} -result {1 1} + +test toggleswitch-2.2 "default -size and -style option values" -body { + ttk::toggleswitch .sw + list [.sw cget -size] [.sw cget -style] [.sw style] [winfo class .sw] +} -cleanup { + destroy .sw +} -result {2 Toggleswitch2 Toggleswitch2 Toggleswitch} + +test toggleswitch-2.3 "-size and -style options" -body { + ttk::toggleswitch .sw -size 3 -style My.Toggleswitch3 + list [.sw cget -size] [.sw cget -style] [.sw style] [winfo class .sw] +} -cleanup { + destroy .sw +} -result {3 My.Toggleswitch3 My.Toggleswitch3 Toggleswitch} + +test toggleswitch-2.4 "-style option" -body { + ttk::toggleswitch .sw + .sw configure -style My.Toggleswitch3 + list [.sw cget -size] [.sw cget -style] [.sw style] [winfo class .sw] +} -cleanup { + destroy .sw +} -result {3 My.Toggleswitch3 My.Toggleswitch3 Toggleswitch} + +test toggleswitch-2.5 "-size option takes precedence over -style" -body { + ttk::toggleswitch .sw -style My.Toggleswitch3 ;# intentionally 3 + list [.sw cget -size] [.sw cget -style] [.sw style] [winfo class .sw] +} -cleanup { + destroy .sw +} -result {2 My.Toggleswitch2 My.Toggleswitch2 Toggleswitch} + +test toggleswitch-3.1 "switchstate triggers the associated cmd" -body { + ttk::toggleswitch .sw -command { expr {10 * [.sw switchstate]} } + .sw switchstate 1 +} -result 10 + +test toggleswitch-3.2 "toggle triggers the associated cmd" -body { + .sw toggle +} -result 0 + +test toggleswitch-3.3 "changing the variable doesn't trigger the cmd" -body { + .sw configure -offvalue OFF -onvalue ON -variable var + set var ON +} -cleanup { + destroy .sw +} -result ON + +# +# TESTFILE CLEANUP +# + +tcltest::cleanupTests diff --git a/tests/ttk/treetags.test b/tests/ttk/treetags.test index 5934fc2..6094757 100644 --- a/tests/ttk/treetags.test +++ b/tests/ttk/treetags.test @@ -1,12 +1,30 @@ +# +# Tests for tags in the ttk::treeview widget +# + +# +# TESTFILE INITIALIZATION +# -package require tk -package require tcltest 2.2 -namespace import -force tcltest::* -loadTestedCommands +package require tcltest 2.2; # needed in mode -singleproc 0 -### treeview tag invariants: +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [file dirname [tcltest::configure -testdir]] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# LOCAL UTILITY PROCS # +# Treeview tag invariants: + proc itemConstraints {tv item} { # $tag in [$tv item $item -tags] <==> [$tv tag has $tag $item] foreach tag [$tv item $item -tags] { @@ -28,16 +46,20 @@ proc treeConstraints {tv} { itemConstraints $tv {} } + # -### +# COMMON TEST SETUP +# +# For all tests in this test file +# +set tv [ttk::treeview .tv -columns "A B C"] +.tv insert {} end -id item1 -text "Item 1" +pack .tv +treeConstraints $tv -test treetags-1.0 "Setup" -body { - set tv [ttk::treeview .tv -columns "A B C"] - .tv insert {} end -id item1 -text "Item 1" - pack .tv -} -cleanup { - treeConstraints $tv -} +# +# TESTS +# test treetags-1.1 "Bad tag list" -body { $tv item item1 -tags {bad {list}here bad} @@ -267,7 +289,8 @@ test treetags-3.4 "stomp tags in tag binding procedure" -body { } -result [list rm1 item1 <<Remove>> rm2 item1 <<Remove>> rm3 item1 <<Remove>>] # +# TESTFILE CLEANUP +# -test treetags-end "Cleanup" -body { destroy $tv } - +destroy $tv tcltest::cleanupTests diff --git a/tests/ttk/treeview.test b/tests/ttk/treeview.test index 8d70e7a..6026254 100644 --- a/tests/ttk/treeview.test +++ b/tests/ttk/treeview.test @@ -1,16 +1,52 @@ # -# [7Jun2005] TO CHECK: [$tv see {}] -- shouldn't work (at least, shouldn't do -# what it currently does) +# ttk::treeview widget tests # -package require tk -package require tcltest 2.2 -namespace import -force tcltest::* -loadTestedCommands +# NOTES +# +# * [7Jun2005] TO CHECK: [$tv see {}] -- shouldn't work (at least, shouldn't do +# what it currently does) +# +# * NEED: tests for focus item, selection + +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [file dirname [tcltest::configure -testdir]] main.tcl] + +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import scroll +# +# LOCAL UTILITY PROCS +# + +# get list of column IDs from list of display column ids. +# +proc columnids {tv dcols} { + set result [list] + foreach dcol $dcols { + if {[catch { + lappend result [$tv column $dcol -id] + }]} { + lappend result ERROR + } + } + return $result +} + # consistencyCheck -- # Traverse the tree to make sure the item data structures # are properly linked. @@ -28,6 +64,23 @@ proc consistencyCheck {tv {item {}}} { } } +proc identify* {tv comps args} { + foreach {x y} $args { + foreach comp $comps { + lappend result [$tv identify $comp $x $y] + } + } + return $result +} + +proc nostretch {tv} { + foreach col [$tv cget -columns] { + $tv column $col -stretch 0 + } + $tv column #0 -stretch 0 + update idletasks ; # redisplay $tv +} + proc tvSetup {} { destroy .tv ttk::treeview .tv -columns {a b c} @@ -42,6 +95,7 @@ proc tvSetup {} { after 10 update } + proc tvSetupWithItems {} { tvSetup .tv insert {} end -id nn -text "nn" @@ -58,6 +112,10 @@ proc tvSetupWithItems {} { } } +# +# TESTS +# + test treeview-1.1 "columns" -body { tvSetup .tv configure -columns {a b c} @@ -239,6 +297,10 @@ test treeview-3.13 "Re-reattach" -body { list [.tv children {}] $before [.tv detached newnode] } -result {{newfirstone firstnode anotherone onemore lastnode newlastone newnode} 0 0} +# +# COMMON TEST SETUP +# + catch { .tv insert newfirstone end -id x1 .tv insert newfirstone end -id x2 @@ -921,31 +983,9 @@ test treeview-11.17 "<<TreeviewSelect>> when setting the selection" -body { bind .tv <<TreeviewSelect>> {} } -result {2 3 4 5} - -### identify tests: # -proc identify* {tv comps args} { - foreach {x y} $args { - foreach comp $comps { - lappend result [$tv identify $comp $x $y] - } - } - return $result -} - -# get list of column IDs from list of display column ids. +# identify tests # -proc columnids {tv dcols} { - set result [list] - foreach dcol $dcols { - if {[catch { - lappend result [$tv column $dcol -id] - }]} { - lappend result ERROR - } - } - return $result -} test treeview-identify-setup "identify series - setup" -body { destroy .tv @@ -966,6 +1006,11 @@ test treeview-identify-setup "identify series - setup" -body { wm geometry . {} ; pack .tv ; update } + +# +# COMMON TEST SETUP +# + # treeview-identify-setup sets heading row font to Arial with size 10 points, # so the heading line center y-coordinate is (in pixels): set yHLC [expr {([font metrics {Arial 10} -linespace] + 2) / 2.0}] @@ -1016,7 +1061,6 @@ test treeview-identify-7 "vertical scan - headings, no tree" -body { } -result [list heading {} {} cell branch {branch #1} cell item1 {item1 #1} cell item2 {item2 #2} cell item3 {item3 #1}] # Disclosure element name is "Treeitem.indicator" -set disclosure "*.indicator" test treeview-identify-8 "identify element" -body { .tv configure -show {tree} .tv insert branch 0 -id branch2 -open true @@ -1026,7 +1070,7 @@ test treeview-identify-8 "identify element" -body { update idletasks identify* .tv {item element} 4m 5m 12m 15m 20m 25m } -match glob -result [list \ - branch $disclosure branch2 $disclosure branch3 $disclosure] + branch "*.indicator" branch2 "*.indicator" branch3 "*.indicator"] test treeview-identify-8.1 "identify element" -body { .tv configure -show {tree headings} @@ -1035,6 +1079,10 @@ test treeview-identify-8.1 "identify element" -body { # Heading elements are currently not reported } -result [list {} {} text] +# +# COMMON TEST SETUP +# + ttk::style configure Treeview -rowheight 20 # See #2381555 @@ -1227,11 +1275,14 @@ test treeview-rowheight-5 "rowheight adapts to cell padding" -body { ttk::style configure Cell -padding {} } -result [expr {8-5 + 9-5}] -### NEED: tests for focus item, selection +# +# COMMON TEST CLEANUP +# + +destroy .tv ### Misc. tests: -destroy .tv test treeview-1541739 "Root node properly initialized (#1541739)" -setup { ttk::treeview .tv .tv insert {} end -id a @@ -1302,14 +1353,6 @@ test treeview-ce470f20fd-1 "dragging further than the right edge of the treeview destroy .tv } -result {200 1} -proc nostretch {tv} { - foreach col [$tv cget -columns] { - $tv column $col -stretch 0 - } - $tv column #0 -stretch 0 - update idletasks ; # redisplay $tv -} - test treeview-ce470f20fd-2 "changing -stretch resizes columns" -setup { pack [ttk::treeview .tv -columns {bar colA colB colC foo}] foreach col [.tv cget -columns] { @@ -1501,7 +1544,7 @@ test treeview-23.1 "cell padding" -setup { } -result {2 4 6 8} # -# CLEANUP +# TESTFILE CLEANUP # testutils forget scroll diff --git a/tests/ttk/ttk.test b/tests/ttk/ttk.test index 022efa6..76c6eea 100644 --- a/tests/ttk/ttk.test +++ b/tests/ttk/ttk.test @@ -1,11 +1,66 @@ +# +# Diverse tests for ttk +# -package require tk -package require tcltest 2.2 -namespace import -force tcltest::* -loadTestedCommands +# +# TESTFILE INITIALIZATION +# -proc skip args {} -proc ok {} { return } +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [file dirname [tcltest::configure -testdir]] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# LOCAL UTILITY PROCS +# + +proc bgerror {error} { + variable bgerror $error + variable bgerrorInfo $::errorInfo + variable bgerrorCode $::errorCode +} + +# Tests using this will fail if the top-level window contains the cursor +proc checkstate {w} { + foreach statespec { + {!active !disabled} + {!active disabled} + {active !disabled} + {active disabled} + active + disabled + } { + lappend result [$w instate $statespec] + } + set result +} + +proc selfdestruct {w args} { + destroy $w +} + +proc wrong#args {args} { + return "wrong # args: should be \"$args\"" +} + +proc wrong#varargs {varpart args} { + set usage $args + append usage " ?$varpart ...?" + return "wrong # args: should be \"$usage\"" +} + +# +# COMMON TEST SETUP +# variable widgetClasses { button checkbutton radiobutton menubutton label entry @@ -15,18 +70,15 @@ variable widgetClasses { scale } -proc bgerror {error} { - variable bgerror $error - variable bgerrorInfo $::errorInfo - variable bgerrorCode $::errorCode -} +# +# TESTS +# +# # Self-destruct tests. # Do these early, so any memory corruption has a longer time to cause a crash. # -proc selfdestruct {w args} { - destroy $w -} + test ttk-6.1 "Self-destructing checkbutton" -body { pack [ttk::checkbutton .sd -text "Self-destruction" -variable ::sd] trace add variable sd write [list selfdestruct .sd] @@ -154,22 +206,6 @@ test ttk-1.4 "Original style preserved" -body { .t cget -style } -result "" -# Tests using this will fail if the top-level window contains the cursor - -proc checkstate {w} { - foreach statespec { - {!active !disabled} - {!active disabled} - {active !disabled} - {active disabled} - active - disabled - } { - lappend result [$w instate $statespec] - } - set result -} - test ttk-2.0 "Check state" -body { checkstate .t } -result [list 1 0 0 0 0 0] @@ -285,7 +321,7 @@ test ttk-4.0 "Setup" -body { catch { destroy .t } pack [ttk::label .t -text "Button 1"] testConstraint fontOption [expr {![catch { set prevFont [.t cget -font] }]}] - ok + return -code ok } test ttk-4.1 "Change font" -constraints fontOption -body { @@ -317,6 +353,12 @@ test ttk-4.4 "Bad resource specifications" -body { } # +# COMMON TEST SETUP +# +# For tests ttk-8.* +# + +# # -compound tests: # variable iconData \ @@ -331,26 +373,12 @@ zCDoBooud2PMDIKuRqDocgtGzMwg6O4Eii5z4Kgi6DIMhqLoagQGjiqCLvPgYOgqji6CLrfi variable compoundStrings {text image center top bottom left right none} -if {0} { - proc now {} { set ::now [clock clicks -milliseconds] } - proc tick {} { puts -nonewline stderr "+" ; flush stderr } - proc tock {} { - set then $::now; set ::now [clock clicks -milliseconds] - puts stderr " [expr {$::now - $then}] ms" - } -} else { - proc now {} {} ; proc tick {} {} ; proc tock {} {} -} - -now ; tick test ttk-8.0 "Setup for 8.X" -body { ttk::button .ctb image create photo icon -data $::iconData; pack .ctb } -tock -now test ttk-8.1 "Test -compound options" -body { # Exhaustively test each combination. # Main goal is to make sure no code paths crash. @@ -358,12 +386,11 @@ test ttk-8.1 "Test -compound options" -body { foreach text {"Hi!" ""} { foreach compound $::compoundStrings { .ctb configure -image $image -text $text -compound $compound - update; tick + update } } } } -tock test ttk-8.2 "Test -compound options with regular button" -body { button .rtb @@ -373,31 +400,28 @@ test ttk-8.2 "Test -compound options with regular button" -body { foreach text {"Hi!" ""} { foreach compound [lrange $::compoundStrings 2 end] { .rtb configure -image $image -text $text -compound $compound - update; tick + update } } } } -tock test ttk-8.3 "Rerun test 8.1" -body { foreach image {icon ""} { foreach text {"Hi!" ""} { foreach compound $::compoundStrings { .ctb configure -image $image -text $text -compound $compound - update; tick + update } } } } -tock test ttk-8.4 "ImageChanged" -body { ttk::button .b -image icon icon blank } -cleanup { destroy .b } -#------------------------------------------------------------------------ test ttk-9.1 "Traces on nonexistant namespaces" -body { ttk::checkbutton .tcb -variable foo::bar @@ -640,14 +664,6 @@ test ttk-15.2 {Bug [3341056]: Usage of recreated ttk::checkbutton causes crash} # # (See also: SF#2021443) # -proc wrong#args {args} { - return "wrong # args: should be \"$args\"" -} -proc wrong#varargs {varpart args} { - set usage $args - append usage " ?$varpart ...?" - return "wrong # args: should be \"$usage\"" -} test ttk-ensemble-0 "style element create: insufficient args" -body { ttk::style @@ -687,9 +703,9 @@ test ttk-16.2 {ttk::style theme styles - theme exists} -body { expr {[llength [ttk::style theme styles alt]] > 0} } -result 1 +# +# TESTFILE CLEANUP +# destroy {*}[winfo children .] - tcltest::cleanupTests - -#*EOF* diff --git a/tests/ttk/validate.test b/tests/ttk/validate.test index fc5545f..e687a15 100644 --- a/tests/ttk/validate.test +++ b/tests/ttk/validate.test @@ -1,23 +1,47 @@ -## -## Entry widget validation tests -## Derived from core test suite entry-19.1 through entry-19.20 -## +# +# Entry widget validation tests +# Derived from core test suite entry-19.1 through entry-19.20 +# + +# +# TESTFILE INITIALIZATION +# -package require tk -package require tcltest 2.2 -eval tcltest::configure $argv -namespace import -force tcltest::* -loadTestedCommands +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [file dirname [tcltest::configure -testdir]] main.tcl] + +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import entry -foreach i {1 2 3 4} { - set validateCmd$i [list validateCommand$i %W %d %i %P %s %S %v %V] -} + +# +# LOCAL TEST CONSTRAINTS +# testConstraint ttkEntry 1 testConstraint coreEntry [expr {![testConstraint ttkEntry]}] +testConstraint NA 0 + +# +# COMMON TEST SETUP +# +foreach i {1 2 3 4} { + set validateCmd$i [list validateCommand$i %W %d %i %P %s %S %v %V] +} + +# +# TESTS +# test validate-0.0 "Setup" -constraints ttkEntry -body { rename entry {} @@ -96,7 +120,12 @@ test validate-1.9 {entry widget validation - vmode focus} -body { set validationData } -result {.e -1 -1 abcd abcd {} focus focusout} +# +# COMMON TEST SETUP +# + .e configure -validate all + test validate-1.10 {entry widget validation - vmode all} -body { set validationData {} set timer [after 300 validationData lappend timeout] @@ -114,6 +143,11 @@ test validate-1.11 {entry widget validation} -body { after cancel $timer set validationData } -result {.e -1 -1 abcd abcd {} all focusout} + +# +# COMMON TEST SETUP +# + .e configure -validate focusin test validate-1.12 {entry widget validation} -body { @@ -131,6 +165,11 @@ test validate-1.13 {entry widget validation} -body { update set validationData } -result {} + +# +# COMMON TEST SETUP +# + .e configure -validate focuso test validate-1.14 {entry widget validation} -body { @@ -198,6 +237,10 @@ test validate-2.1 "Validation script changes value" -body { } -result {dovaldata dovaldata {.e -1 -1 testdata testdata {} all forced}} # DIFFERENCE: core entry disables validation, ttk entry does not. +# +# COMMON TEST CLEANUP +# + destroy .e catch {unset textVar} @@ -245,7 +288,6 @@ test validate-3.4 "revalidate" -body { return [list [.e validate] [.e get] [.e state]] } -result [list 0 1234XY {invalid}] -testConstraint NA 0 # the next two tests (used to) exercise validation lockout protection -- # if the widget is currently invalid, all edits are allowed. # This behavior is currently disabled. @@ -263,7 +305,7 @@ test validate-3.6 "...until the value becomes valid" -constraints NA -body { test validate-3.last "Cleanup" -body { destroy .e } # -# CLEANUP +# TESTFILE CLEANUP # foreach i {1 2 3 4} { diff --git a/tests/ttk/vsapi.test b/tests/ttk/vsapi.test index 02f6309..9bad7ce 100644 --- a/tests/ttk/vsapi.test +++ b/tests/ttk/vsapi.test @@ -1,15 +1,37 @@ -# -*- tcl -*- +# +# Tests exercising Microsoft Visual Styles elements, defined through +# the command "ttk::style element create XXX vsapi" +# + +# +# TESTFILE INITIALIZATION # -package require tk -package require tcltest 2.2 -namespace import -force tcltest::* -loadTestedCommands +package require tcltest 2.2; # needed in mode -singleproc 0 -testConstraint xpnative \ - [expr {"xpnative" in [ttk::style theme names]}] +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [file dirname [tcltest::configure -testdir]] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# LOCAL TEST CONSTRAINTS +# -test vsapi-1.1 "WINDOW WP_SMALLCLOSEBUTTON" -constraints {xpnative} -body { +testConstraint vista \ + [expr {"vista" in [ttk::style theme names]}] + +# +# TESTS +# + +test vsapi-1.1 "WINDOW WP_SMALLCLOSEBUTTON" -constraints vista -body { ttk::style element create smallclose vsapi \ WINDOW 19 {disabled 4 pressed 3 active 2 {} 1} ttk::style layout CloseButton {CloseButton.smallclose -sticky news} @@ -18,7 +40,7 @@ test vsapi-1.1 "WINDOW WP_SMALLCLOSEBUTTON" -constraints {xpnative} -body { list [winfo reqwidth .b] [winfo reqheight .b] } -cleanup { destroy .b } -result [list 13 13] -test vsapi-1.2 "EXPLORERBAR EBP_HEADERPIN" -constraints {xpnative} -body { +test vsapi-1.2 "EXPLORERBAR EBP_HEADERPIN" -constraints vista -body { ttk::style element create pin vsapi \ EXPLORERBAR 3 { {pressed !selected} 3 @@ -34,7 +56,7 @@ test vsapi-1.2 "EXPLORERBAR EBP_HEADERPIN" -constraints {xpnative} -body { list [winfo reqwidth .pin] [winfo reqheight .pin] } -cleanup { destroy .pin } -result [list 16 16] -test vsapi-1.3 "EXPLORERBAR EBP_HEADERCLOSE" -constraints {xpnative} -body { +test vsapi-1.3 "EXPLORERBAR EBP_HEADERCLOSE" -constraints vista -body { ttk::style element create headerclose vsapi \ EXPLORERBAR 2 {pressed 3 active 2 {} 1} ttk::style layout Explorer.CloseButton { @@ -45,4 +67,8 @@ test vsapi-1.3 "EXPLORERBAR EBP_HEADERCLOSE" -constraints {xpnative} -body { list [winfo reqwidth .b] [winfo reqheight .b] } -cleanup { destroy .b } -result [list 16 16] +# +# TESTFILE CLEANUP +# + tcltest::cleanupTests diff --git a/tests/unixButton.test b/tests/unixButton.test index 501e779..27c329c 100644 --- a/tests/unixButton.test +++ b/tests/unixButton.test @@ -1,23 +1,38 @@ # This file is a Tcl script to test the Unix specific behavior of # labels, buttons, checkbuttons, and radiobuttons in Tk (i.e., all the -# widgets defined in tkUnixButton.c). It is organized in the standard -# fashion for Tcl tests. +# widgets defined in tkUnixButton.c). # # Copyright © 1994 The Regents of the University of California. # Copyright © 1994-1997 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -namespace import -force tcltest::test -eval tcltest::configure $argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import button image imageInit +# +# COMMON TEST SETUP +# + # Create entries in the option database to be sure that geometry options # like border width have predictable values. @@ -43,6 +58,11 @@ if {[tk windowingsystem] eq "aqua"} { set bigIndicator 40 set defaultBorder 20 } + +# +# TESTS +# + test unixbutton-1.1 {TkpComputeButtonGeometry procedure} -constraints { unix testImageType } -setup { @@ -258,13 +278,12 @@ test unixbutton-2.1 {disabled coloring check, bug 669595} -constraints { } -result 1 # -# CLEANUP +# TESTFILE CLEANUP # imageFinish testutils forget button image cleanupTests -return # Local variables: # mode: tcl diff --git a/tests/unixEmbed.test b/tests/unixEmbed.test index 0270a98..febd157 100644 --- a/tests/unixEmbed.test +++ b/tests/unixEmbed.test @@ -1,22 +1,41 @@ # This file is a Tcl script to test out the procedures in the file -# tkUnixEmbed.c. It is organized in the standard fashion for Tcl -# tests. +# tkUnixEmbed.c. # # Copyright © 1996-1997 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -eval tcltest::configure $argv -tcltest::loadTestedCommands -namespace import -force tcltest::test +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import colors child +# +# COMMON TEST SETUP +# + childTkProcess create childTkProcess eval {wm withdraw .} +# +# TESTS +# + test unixEmbed-1.1 {Tk_UseWindow procedure, bad window identifier} -constraints { unix } -setup { @@ -1102,6 +1121,10 @@ test unixEmbed-8.2 {TkpClaimFocus procedure} -constraints unix -setup { } -cleanup { deleteWindows } -result {{{} .} .f1} + +# +# COMMON TEST CLEANUP +# catch {interp delete child} test unixEmbed-9.1 {EmbedWindowDeleted procedure, check parentPtr} -constraints { @@ -1253,11 +1276,10 @@ test unixEmbed-11.2 {mouse coordinates in embedded toplevels} -constraints { } -result {.main.b {pushed .main.b} .embed.b {pushed .embed.b}} # -# CLEANUP +# TESTFILE CLEANUP # deleteWindows childTkProcess exit testutils forget child colors cleanupTests -return diff --git a/tests/unixFont.test b/tests/unixFont.test index b97a607..dea4f17 100644 --- a/tests/unixFont.test +++ b/tests/unixFont.test @@ -1,5 +1,4 @@ # This file is a Tcl script to test out the procedures in tkUnixFont.c. -# It is organized in the standard fashion for Tcl tests. # # Many of these tests are visually oriented and cannot be checked # programmatically (such as "does an underlined font appear to be @@ -12,13 +11,30 @@ # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -eval tcltest::configure $argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import geometry +# +# LOCAL TEST CONSTRAINTS +# + if {[tk windowingsystem] eq "x11"} { if {[testConstraint withXft]} { set fontsystemcmd [auto_execok fc-list] @@ -26,6 +42,7 @@ if {[tk windowingsystem] eq "x11"} { set fontsystemcmd [auto_execok xlsfonts] } } + foreach {constraint font} { hasArial arial hasCourierNew "courier new" @@ -53,6 +70,10 @@ foreach {constraint font} { } } +# +# COMMON TEST SETUP +# + catch {destroy .b} toplevel .b wm geom .b +0+0 @@ -75,6 +96,10 @@ set cx [font measure TkFixedFont 0] set ax [winfo reqwidth .b.l] set ay [winfo reqheight .b.l] +# +# TESTS +# + test unixfont-1.1 {TkpGetNativeFont procedure: not native} {x11} { list [catch {font measure {} xyz} msg] $msg } {1 {font "" does not exist}} @@ -155,7 +180,13 @@ test unixfont-5.3 {Tk_MeasureChars procedure: loop over chars} x11 { .b.l config -text "0\3770\377" .b.l config -text "000000000000000" } {} + +# +# COMMON TEST SETUP +# + .b.l config -wrap [expr $ax*10] + test unixfont-5.4 {Tk_MeasureChars procedure: reached right edge} x11 { .b.l config -text "0000000000000" getsize .b.l @@ -329,9 +360,8 @@ test unixfont-9.2 {4 chars substituted in inserted text} {x11 nonPortable} { } {0 1 1 1 1 2} # -# CLEANUP +# TESTFILE CLEANUP # testutils forget geometry cleanupTests -return diff --git a/tests/unixMenu.test b/tests/unixMenu.test index 57b3029..65d2d19 100644 --- a/tests/unixMenu.test +++ b/tests/unixMenu.test @@ -1,5 +1,4 @@ -# This file is a Tcl script to test menus in Tk. It is -# organized in the standard fashion for Tcl tests. This +# This file is a Tcl script to test menus in Tk. This # file tests the Macintosh-specific features of the menu # system. # @@ -7,11 +6,26 @@ # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -eval tcltest::configure $argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows +# +# TESTS +# test unixMenu-1.1 {TkpNewMenu - normal menu} -constraints unix -setup { destroy .m1 @@ -1267,9 +1281,9 @@ test unixMenu-25.20 {TkpComputeStandardMenuGeometry - hide margin} -constraints test unixMenu-26.1 {TkpMenuInit - nothing to do} -constraints unix -body {} +# +# TESTFILE CLEANUP +# - -# cleanup deleteWindows cleanupTests -return diff --git a/tests/unixSelect.test b/tests/unixSelect.test index 59d02c6..4e2ae21 100644 --- a/tests/unixSelect.test +++ b/tests/unixSelect.test @@ -1,22 +1,34 @@ # This file contains tests for the tkUnixSelect.c file. # -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# # Copyright © 1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2.2 -namespace import ::tcltest::* -tcltest::configure {*}$argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import child select +# +# COMMON TEST SETUP +# + # Eliminate any existing selection on the screen. This is needed in case # there is a selection in some other application, in order to prevent races # from causing false errors in the tests below. @@ -30,7 +42,9 @@ foreach i {a b c d e f g j h i j k l m o p q r s t u v w x y z} { append longValue A$j B$j C$j D$j E$j F$j G$j H$j I$j K$j L$j M$j N$j } -# ---------------------------------------------------------------------- +# +# TESTS +# test unixSelect-1.1 {TkSelGetSelection procedure: simple i18n text} -constraints { x11 @@ -190,6 +204,7 @@ test unixSelect-1.9 {TkSelGetSelection procedure: INCR i18n text} -constraints { } -cleanup { childTkProcess exit } -result [string repeat x 3999]ü[string repeat x 4000] + # Now some tests to make sure that the right thing is done when # transferring UTF8 selections, to prevent [Bug 614650] and its ilk # from rearing its ugly head again. @@ -358,9 +373,8 @@ test unixSelect-1.19 {Automatic UTF8_STRING support for selection handle} -const } -result {This is the selection value} # -# CLEANUP +# TESTFILE CLEANUP # testutils forget child select cleanupTests -return diff --git a/tests/unixWm.test b/tests/unixWm.test index 5c02963..fa522fd 100644 --- a/tests/unixWm.test +++ b/tests/unixWm.test @@ -1,18 +1,36 @@ # This file is a Tcl script to test out Tk's interactions with -# the window manager, including the "wm" command. It is organized -# in the standard fashion for Tcl tests. +# the window manager, including the "wm" command. # # Copyright © 1992-1994 The Regents of the University of California. # Copyright © 1994-1997 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -eval tcltest::configure $argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 -# Procedure to set up a collection of top-level windows +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] +# Ensure a pristine initial window state +resetWindows + +# +# LOCAL UTILITY PROCS +# + +# makeToplevels -- +# +# Set up a collection of top-level windows +# proc makeToplevels {} { deleteWindows foreach i {.raise1 .raise2 .raise3} { @@ -22,6 +40,10 @@ proc makeToplevels {} { } } +# +# COMMON TEST SETUP +# + # On macOS windows are not allowed to overlap the menubar at the top of the # screen or the dock. So tests which move a window and then check whether it # got moved to the requested location should use a y coordinate larger than the @@ -30,7 +52,6 @@ proc makeToplevels {} { # macOS 15 (Sequoia) it became impossible for the y coordinate of the top # of a window to be less than 10 plus the menubar height (as reported by # [[NSApp mainMenu] menuBarHeight]). - if {[tk windowingsystem] eq "aqua"} { set mb [expr [testmenubarheight] + 11] set X 100 @@ -44,6 +65,10 @@ if {[tk windowingsystem] eq "aqua"} { set Y5 5 } +# +# TESTS +# + set i 1 foreach geom "+$X+80 +80+$Y0 +$X+$Y0" { destroy .t @@ -56,12 +81,14 @@ foreach geom "+$X+80 +80+$Y0 +$X+$Y0" { incr i } +# +# COMMON TEST SETUP +# + # The tests below are tricky because window managers don't all move # windows correctly. Try one motion and compute the window manager's # error, then factor this error into the actual tests. In other words, # this just makes sure that things are consistent between moves. - -set i 1 destroy .t toplevel .t -width 100 -height 150 wm geom .t +200+200 @@ -71,6 +98,8 @@ update scan [wm geom .t] %dx%d+%d+%d width height x y set xerr [expr 150-$x] set yerr [expr 150-$y] + +set i 1 foreach geom "+20+80 +80+$Y0 +0+$Y0 -0-0 +0-0 -0+$Y0 -10-5 -10+$Y5 +10-5" { test unixWm-2.$i {moving window while mapped} unix { wm geom .t $geom @@ -182,11 +211,16 @@ test unixWm-5.7 {compounded state changes} {unix nonPortable} { list [winfo ismapped .t] [wm state .t] } {0 iconic} +# +# COMMON TEST SETUP +# + destroy .t toplevel .t -width 200 -height 100 wm geom .t +100+$Y0 wm minsize .t 1 1 update + test unixWm-6.1 {size changes} unix { .t config -width 180 -height 150 update @@ -240,6 +274,10 @@ test unixWm-6.5 {window initially iconic} {unix nonPortable} { list [winfo ismapped .t] [wm state .t] } {1 normal} +# +# COMMON TEST SETUP +# + destroy .m toplevel .m wm overrideredirect .m 1 @@ -248,20 +286,26 @@ foreach i {{Test label} Another {Yet another} {Last label}} j {1 2 3} { } wm geometry .m +[expr 100 - [winfo vrootx .]]+[expr 200 - [winfo vrooty .]] update + test unixWm-7.1 {override_redirect and Tk_MoveTopLevelWindow} unix { list [winfo ismapped .m] [wm state .m] [winfo x .m] [winfo y .m] } {1 normal 100 200} -wm geometry .m +[expr 150 - [winfo vrootx .]]+[expr 210 - [winfo vrooty .]] -update -test unixWm-7.2 {override_redirect and Tk_MoveTopLevelWindow} unix { + +test unixWm-7.2 {override_redirect and Tk_MoveTopLevelWindow} -constraints unix -setup { + wm geometry .m +[expr 150 - [winfo vrootx .]]+[expr 210 - [winfo vrooty .]] + update +} -body { list [winfo ismapped .m] [wm state .m] [winfo x .m] [winfo y .m] -} {1 normal 150 210} -wm withdraw .m -test unixWm-7.3 {override_redirect and Tk_MoveTopLevelWindow} unix { +} -result {1 normal 150 210} + +test unixWm-7.3 {override_redirect and Tk_MoveTopLevelWindow} -constraints unix -setup { + wm withdraw .m +} -body { list [winfo ismapped .m] -} 0 -destroy .m -destroy .t +} -cleanup { + destroy .m + destroy .t +} -result 0 test unixWm-8.1 {icon windows} unix { destroy .t @@ -311,7 +355,7 @@ test unixWm-8.6 {icon windows} unix { frame .t.icon -width 50 -height 50 -bg red list [catch {wm iconwindow .t .t.icon} msg] $msg } {1 {can't use .t.icon as icon window: not at top level}} -test unixWm-8.7 {icon windows} unix { +test unixWm-8.7 {icon windows} -constraints unix -body { destroy .t destroy .icon toplevel .t -width 100 -height 30 @@ -322,8 +366,9 @@ test unixWm-8.7 {icon windows} unix { set result "[wm iconwindow .t] [wm state .icon] [wm state .icon2]" wm iconwindow .t .icon2 lappend result [wm iconwindow .t] [wm state .icon] [wm state .icon2] -} {.icon icon normal .icon2 withdrawn icon} -destroy .icon2 +} -cleanup { + destroy .icon2 +} -result {.icon icon normal .icon2 withdrawn icon} test unixWm-8.8 {icon windows} unix { destroy .t destroy .icon @@ -462,9 +507,12 @@ test unixWm-11.4 {Tk_WmCmd procedure, miscellaneous errors} unix { list [catch {wm geometry .b} msg] $msg } {1 {window ".b" isn't a top-level window}} +# +# COMMON TEST SETUP +# + destroy .t destroy .icon - toplevel .t -width 100 -height 50 wm geom .t +0+0 update @@ -583,6 +631,10 @@ test unixWm-14.7 {Tk_WmCmd procedure, "colormapwindows" option} unix { wm colormapwindows .t2 {} list $x [wm colormapwindows .t2] } {{} {}} + +# +# COMMON TEST CLEANUP +# destroy .t2 test unixWm-15.1 {Tk_WmCmd procedure, "command" option} unix { @@ -744,6 +796,10 @@ test unixWm-20.11 {Tk_WmCmd procedure, "grid" option} unix { list [catch {wm grid .t 10 11 12 -1} msg] $msg } {1 {heightInc can't be <= 0}} +# +# COMMON TEST SETUP +# + destroy .t destroy .icon toplevel .t -width 100 -height 50 @@ -991,6 +1047,10 @@ test unixWm-27.7 {Tk_WmCmd procedure, "iconwindow" option, withdrawing icon} uni set result } {normal 1 icon 0} +# +# COMMON TEST SETUP +# + destroy .t destroy .icon toplevel .t -width 100 -height 50 @@ -1069,6 +1129,10 @@ test unixWm-29.3 {Tk_WmCmd procedure, "minsize" option, setting the format {%d %d} [lindex $hints 5] [lindex $hints 6] } {300 300} +# +# COMMON TEST SETUP +# + destroy .t .icon toplevel .t -width 100 -height 50 wm geom .t +0+0 @@ -1212,14 +1276,12 @@ test unixWm-34.2 {Tk_WmCmd procedure, "sizefrom" option} {unix testwrapper} { test unixWm-34.3 {Tk_WmCmd procedure, "sizefrom" option} unix { list [catch {wm sizefrom .t none} msg] $msg } {1 {bad argument "none": must be program or user}} -if {[tk windowingsystem] eq "aqua"} { - set result_35_1 {1 {bad argument "1": must be iconic, normal, withdrawn, or zoomed}} -} else { - set result_35_1 {1 {bad argument "1": must be iconic, normal, or withdrawn}} -} -test unixWm-35.1 {Tk_WmCmd procedure, "state" option} {unix notAqua} { +test unixWm-35.1.1 {Tk_WmCmd procedure, "state" option} {unix notAqua} { + list [catch {wm state .t 1} msg] $msg +} {1 {bad argument "1": must be iconic, normal, or withdrawn}} +test unixWm-35.1.2 {Tk_WmCmd procedure, "state" option} {unix aqua} { list [catch {wm state .t 1} msg] $msg -} $result_35_1 +} {1 {bad argument "1": must be iconic, normal, withdrawn, or zoomed}} test unixWm-35.2 {Tk_WmCmd procedure, "state" option} unix { list [catch {wm state .t iconic 1} msg] $msg } {1 {wrong # args: should be "wm state window ?state?"}} @@ -1336,6 +1398,9 @@ test unixWm-39.1 {Tk_WmCmd procedure, miscellaneous} unix { list [catch {wm unknown .t} msg] $msg } {1 {bad option "unknown": must be aspect, attributes, client, colormapwindows, command, deiconify, focusmodel, forget, frame, geometry, grid, group, iconbadge, iconbitmap, iconify, iconmask, iconname, iconphoto, iconposition, iconwindow, manage, maxsize, minsize, overrideredirect, positionfrom, protocol, resizable, sizefrom, stackorder, state, title, transient, or withdraw}} +# +# COMMON TEST CLEANUP +# destroy .t .icon test unixWm-40.1 {Tk_SetGrid procedure, set grid dimensions before turning on grid} {unix nonPortable} { @@ -1528,9 +1593,11 @@ test unixWm-44.5 {UpdateGeometryInfo procedure, negative width} unix { update list [winfo width .t] [winfo height .t] } {1 72} -destroy .t -toplevel .t -width 80 -height 60 -test unixWm-44.6 {UpdateGeometryInfo procedure, negative height} unix { + +test unixWm-44.6 {UpdateGeometryInfo procedure, negative height} -constraints unix -setup { + destroy .t + toplevel .t -width 80 -height 60 +} -body { wm grid .t 18 7 10 12 wm geometry .t +30+40 wm overrideredirect .t 1 @@ -1538,28 +1605,44 @@ test unixWm-44.6 {UpdateGeometryInfo procedure, negative height} unix { wm geometry .t 20x1 update list [winfo width .t] [winfo height .t] -} {100 1} -destroy .t -toplevel .t -width 80 -height 60 -test unixWm-44.7 {UpdateGeometryInfo procedure, computing position} {unix} { +} -result {100 1} + +# +# COMMON TEST SETUP +# +if {! [winfo exists .t]} { + # The expected results for tests 44.7 and 44.8 require that window .t exists. + # That might not be the case if no previous tests are being run that create + # the window (because of the constraint unix or because of test selection + # using the tcltest option "-match" or "-skip"). Therefore, we create a dummy + # window .t here. + frame .t +} + +test unixWm-44.7 {UpdateGeometryInfo procedure, computing position} -constraints unix -setup { + destroy .t + toplevel .t -width 80 -height 60 +} -body { wm overrideredirect .t 1 tkwait visibility .t update wm geometry .t +5-10 update list [winfo x .t] [winfo y .t] -} [list 5 [expr [winfo screenheight .t] - 70]] -destroy .t -toplevel .t -width 80 -height 60 -test unixWm-44.8 {UpdateGeometryInfo procedure, computing position} {unix} { +} -result [list 5 [expr [winfo screenheight .t] - 70]] +test unixWm-44.8 {UpdateGeometryInfo procedure, computing position} -constraints unix -setup { + destroy .t + toplevel .t -width 80 -height 60 +} -body { wm overrideredirect .t 1 tkwait visibility .t update wm geometry .t -30+$Y2 update list [winfo x .t] [winfo y .t] -} [list [expr [winfo screenwidth .t] - 110] $Y2] -destroy .t +} -cleanup { + destroy .t +} -result [list [expr [winfo screenwidth .t] - 110] $Y2] test unixWm-44.9 {UpdateGeometryInfo procedure, updating fixed dimensions} {unix testwrapper} { destroy .t @@ -1686,6 +1769,10 @@ test unixWm-47.1 {WaitRestrictProc procedure} {unix nonPortable} { # I don't know how to test WaitTimeoutProc, WaitForMapNotify, or UpdateHints. +# +# COMMON TEST SETUP +# + destroy .t toplevel .t -width 300 -height 200 wm geometry .t +0+0 @@ -1774,10 +1861,15 @@ test unixWm-49.2 {Tk_GetRootCoords procedure, menubars} {unix testmenubar} { [expr [winfo rootx .t.f] - $x] [expr [winfo rooty .t.f] - $y] } {52 7 12 62} +# +# COMMON TEST SETUP +# + deleteWindows # Make sure that the root window is out of the way! wm geom . +700+700 wm withdraw . + if {[tk windowingsystem] eq "aqua"} { # Modern mac windows have no border. set result_50_1 {{} {} .t .t .t2 {} .t2 .t .t} @@ -1785,6 +1877,11 @@ if {[tk windowingsystem] eq "aqua"} { # Windows are assumed to have a border (invisible in Gnome 3). set result_50_1 {{} {} .t {} .t2 {} .t2 {} .t} } + +if {[tk windowingsystem] eq "aqua"} { + after 1000; # Give Apple's _windowserver some time to catch up. +} + test unixWm-50.1 {Tk_CoordsToWindow procedure, finding a toplevel, x-coords, title bar} {unix failsOnUbuntu failsOnXQuartz} { update toplevel .t -width 300 -height 400 -bg green @@ -1983,6 +2080,10 @@ test unixWm-50.10 {Tk_CoordsToWindow procedure, unmapped windows} unix { update idletasks lappend result [winfo containing 100 100] } {.t.f .t} + +# +# COMMON TEST CLEANUP +# deleteWindows wm deiconify . @@ -2037,7 +2138,12 @@ test unixWm-51.5 {TkWmRestackToplevel procedure, basic tests} {unix nonPortable} list $result [winfo containing [winfo rootx .raise2] \ [winfo rooty .raise2]] } {.raise1 .raise3} + +# +# COMMON TEST CLEANUP +# deleteWindows + test unixWm-51.6 {TkWmRestackToplevel procedure, window to be stacked isn't mapped} unix { wm geometry . +300+300 destroy .t @@ -2093,12 +2199,14 @@ test unixWm-51.8 {TkWmRestackToplevel procedure, overrideredirect windows} unix raise .t2 lappend result [winfo containing $x $y] } {.t2 .t .t2} -# The mac won't put an overrideredirect window above the root, -if {[tk windowingsystem] eq "aqua"} { - wm withdraw . - update -} -test unixWm-51.9 {TkWmRestackToplevel procedure, other window overrideredirect} unix { + +test unixWm-51.9 {TkWmRestackToplevel procedure, other window overrideredirect} -constraints unix -setup { + # The mac won't put an overrideredirect window above the root, + if {[tk windowingsystem] eq "aqua"} { + wm withdraw . + update + } +} -body { foreach w {.t .t2 .t3} { destroy $w update @@ -2122,11 +2230,12 @@ test unixWm-51.9 {TkWmRestackToplevel procedure, other window overrideredirect} lower .t2 update lappend result [winfo containing $x $y] -} {.t2 .t3} -if {[tk windowingsystem] eq "aqua"} { - wm deiconify . - update -} +} -cleanup { + if {[tk windowingsystem] eq "aqua"} { + wm deiconify . + update + } +} -result {.t2 .t3} test unixWm-51.10 {TkWmRestackToplevel procedure, don't move window that's already in the right place} unix { makeToplevels raise .raise1 @@ -2502,18 +2611,17 @@ test unixWm-59.3 {exit processing} unix { # NOTE: since [wm attributes] is not guaranteed to have any effect, # the only thing we can really test here is the syntax. # -if {[tk windowingsystem] eq "aqua"} { - set match_60_1 glob - set result_60_1 {-alpha 1.0 -appearance auto -buttons {close miniaturize zoom} -fullscreen 0 -isdark [01] -modified 0 -notify 0 -titlepath {} -topmost 0 -transparent 0 -stylemask {titled closable miniaturizable resizable} -class nswindow -tabbingid .t -tabbingmode auto -type unsupported} -} else { - set match_60_1 exact - set result_60_1 {-alpha 1.0 -fullscreen 0 -topmost 0 -type {} -zoomed 0} -} -test unixWm-60.1 {wm attributes - test} -constraints unix -body { +test unixWm-60.1.1 {wm attributes - test} -constraints {unix notAqua} -body { + destroy .t + toplevel .t + wm attributes .t +} -match exact -result {-alpha 1.0 -fullscreen 0 -topmost 0 -type {} -zoomed 0} + +test unixWm-60.1.2 {wm attributes - test} -constraints {unix aqua} -body { destroy .t toplevel .t wm attributes .t -} -match $match_60_1 -result $result_60_1 +} -match glob -result {-alpha 1.0 -appearance auto -buttons {close miniaturize zoom} -fullscreen 0 -isdark [01] -modified 0 -notify 0 -titlepath {} -topmost 0 -transparent 0 -stylemask {titled closable miniaturizable resizable} -class nswindow -tabbingid .t -tabbingmode auto -type unsupported} test unixWm-60.2 {wm attributes - test} -constraints unix -body { destroy .t @@ -2600,7 +2708,9 @@ test unixWm-62.4 {wm attributes -type list} -constraints unix -setup { destroy .t } -result {} -# cleanup +# +# TESTFILE CLEANUP +# + destroy .t cleanupTests -return diff --git a/tests/util.test b/tests/util.test index c2baa38..c6fac0a 100644 --- a/tests/util.test +++ b/tests/util.test @@ -1,20 +1,41 @@ # This file is a Tcl script to test out the procedures in the file -# tkUtil.c. It is organized in the standard fashion for Tcl tests. +# tkUtil.c. # # Copyright © 1994 The Regents of the University of California. # Copyright © 1994 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -eval tcltest::configure $argv -tcltest::loadTestedCommands -namespace import -force tcltest::test +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# COMMON TEST SETUP +# listbox .l -width 20 -height 5 -relief sunken -bd 2 pack .l .l insert 0 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 update + +# +# TESTS +# + test util-1.1 {Tk_GetScrollInfo procedure} -body { .l yview moveto a b } -returnCodes error -result {wrong # args: should be ".l yview moveto fraction"} @@ -62,7 +83,8 @@ test util-1.12 {Tk_GetScrollInfo procedure} -body { .l yview dropdead 3 times } -returnCodes error -result {unknown option "dropdead": must be moveto or scroll} -# cleanup -cleanupTests -return +# +# TESTFILE CLEANUP +# +cleanupTests diff --git a/tests/visual.test b/tests/visual.test index 05bfcf7..dd6df2a 100644 --- a/tests/visual.test +++ b/tests/visual.test @@ -1,20 +1,35 @@ # This file is a Tcl script to test the visual- and colormap-handling -# procedures in the file tkVisual.c. It is organized in the standard -# fashion for Tcl tests. +# procedures in the file tkVisual.c. # # Copyright © 1994 The Regents of the University of California. # Copyright © 1994-1995 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -tcltest::configure {*}$argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import colors +# +# COMMON TEST SETUP +# + update # If more than one visual type is available for the screen, pick one @@ -31,11 +46,18 @@ if {[llength $avail] > 1} { } } } + +# +# LOCAL TEST CONSTRAINTS +# + testConstraint haveOtherVisual [expr {$other ne ""}] testConstraint havePseudocolorVisual [string match *pseudocolor* $avail] testConstraint haveMultipleVisuals [expr {[llength $avail] > 1}] -# ---------------------------------------------------------------------- +# +# TESTS +# test visual-1.1 {Tk_GetVisual, copying from other window} -body { toplevel .t -visual .foo.bar @@ -520,13 +542,12 @@ test visual-8.2 {Tk_FreeColormap procedure} -constraints haveOtherVisual -setup } -result {} # -# CLEANUP +# TESTFILE CLEANUP # deleteWindows testutils forget colors cleanupTests -return # Local variables: # mode: tcl diff --git a/tests/visual_bb.test b/tests/visual_bb.test index e118838..0d318b9 100644 --- a/tests/visual_bb.test +++ b/tests/visual_bb.test @@ -1,23 +1,44 @@ -#!/usr/local/bin/wish -f -# # This script displays provides visual tests for many of Tk's features. # Each test displays a window with various information in it, along # with instructions about how the window should appear. You can look # at the window to make sure it appears as expected. Individual tests # are kept in separate ".tcl" files in this directory. -package require tcltest 2.2 -namespace import ::tcltest::* -tcltest::configure {*}$argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# +package require tcltest 2.2; # needed in mode -singleproc 0 -set auto_path ". $auto_path" -wm title . "Visual Tests for Tk" +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows set testNum 1 -# Each menu entry invokes a visual test file +# +# LOCAL UTILITY PROCS +# + +proc end {} { + cleanupTests + set ::EndOfVisualTests 1 +} + +# lpr -- +# +# Print the contents of a canvas +# +proc lpr {c args} { + exec lpr <<[eval [list $c postscript] $args] +} proc runTest {file} { global testNum @@ -29,18 +50,18 @@ proc runTest {file} { incr testNum } -# The following procedure is invoked to print the contents of a canvas: +# +# COMMON TEST SETUP +# -proc lpr {c args} { - exec lpr <<[eval [list $c postscript] $args] -} +set auto_path ". $auto_path" +wm title . "Visual Tests for Tk" -proc end {} { - cleanupTests - set ::EndOfVisualTests 1 -} +# +# TESTS +# -# ---------------------------------------------------------------------- +# Each menu entry invokes a visual test file test 1.1 {running visual tests} -constraints userInteraction -body { #------------------------------------------------------- @@ -109,6 +130,10 @@ test 1.1 {running visual tests} -constraints userInteraction -body { concat "" } -result {} +# +# TESTFILE CLEANUP +# + if {![testConstraint userInteraction]} { cleanupTests } else { diff --git a/tests/winButton.test b/tests/winButton.test index 406133a..5963642 100644 --- a/tests/winButton.test +++ b/tests/winButton.test @@ -1,17 +1,28 @@ # This file is a Tcl script to test the Windows specific behavior of # labels, buttons, checkbuttons, and radiobuttons in Tk (i.e., all the -# widgets defined in tkWinButton.c). It is organized in the standard -# fashion for Tcl tests. +# widgets defined in tkWinButton.c). # # Copyright © 1994 The Regents of the University of California. # Copyright © 1994-1997 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -tcltest::configure {*}$argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import button image @@ -20,7 +31,9 @@ imageInit option clear -# ---------------------------------------------------------------------- +# +# TESTS +# test winbutton-1.1 {TkpComputeButtonGeometry procedure} -constraints { testImageType win nonPortable @@ -193,14 +206,13 @@ test winbutton-1.9 {TkpComputeButtonGeometry procedure} -constraints win -setup } -result {23 33} # -# CLEANUP +# TESTFILE CLEANUP # imageFinish deleteWindows testutils forget button image cleanupTests -return # Local variables: # mode: tcl diff --git a/tests/winClipboard.test b/tests/winClipboard.test index cb286f0..284ee90 100644 --- a/tests/winClipboard.test +++ b/tests/winClipboard.test @@ -1,24 +1,36 @@ # This file is a Tcl script to test out Tk's Windows specific -# clipboard code. It is organized in the standard fashion for Tcl -# tests. -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. +# clipboard code. # # Copyright © 1997 Sun Microsystems, Inc. # Copyright © 1998-2000 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -eval tcltest::configure $argv -tcltest::loadTestedCommands -namespace import -force tcltest::test +# NOTE +# +# Some of these tests may fail if another application is grabbing the clipboard +# (e.g. an X server, or a VNC viewer) # + +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] -################################################################# -# Note that some of these tests may fail if another application # -# is grabbing the clipboard (e.g. an X server, or a VNC viewer) # -################################################################# + +# Ensure a pristine initial window state +resetWindows + +# +# TESTS +# test winClipboard-1.1 {TkSelGetSelection} -constraints win -setup { clipboard clear @@ -114,9 +126,11 @@ test winClipboard-2.2 {TkSelUpdateClipboard reentrancy problem} -constraints { clipboard clear } -result {{more data in string} {new data}} -# cleanup +# +# TESTFILE CLEANUP +# + cleanupTests -return # Local variables: # mode: tcl diff --git a/tests/winDialog.test b/tests/winDialog.test index 8f9ad01..d173e2e 100644 --- a/tests/winDialog.test +++ b/tests/winDialog.test @@ -1,16 +1,26 @@ -# -*- tcl -*- # This file is a Tcl script to test the Windows specific behavior of -# the common dialog boxes. It is organized in the standard -# fashion for Tcl tests. +# the common dialog boxes. # # Copyright © 1997 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # Copyright © 1998-1999 ActiveState Corporation. -package require tcltest 2.2 -namespace import ::tcltest::* -tcltest::configure {*}$argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import dialog @@ -20,13 +30,9 @@ if {[testConstraint testwinevent]} { catch {testwinevent debug 1} } -# Locale identifier LANG_ENGLISH is 0x09 -testConstraint english [expr { - [llength [info commands testwinlocale]] - && (([testwinlocale] & 0xff) == 9) -}] - -set initialDir [tcltest::temporaryDirectory] +# +# LOCAL UTILITY PROCS +# proc GetText {id} { variable testDialog @@ -42,7 +48,25 @@ proc SetText {id text} { return [testwinevent $testDialog $id WM_SETTEXT $text] } -# ---------------------------------------------------------------------- +# +# LOCAL TEST CONSTRAINTS +# + +# Locale identifier LANG_ENGLISH is 0x09 +testConstraint english [expr { + [llength [info commands testwinlocale]] + && (([testwinlocale] & 0xff) == 9) +}] + +# +# COMMON TEST SETUP +# + +set initialDir [tcltest::temporaryDirectory] + +# +# TESTS +# test winDialog-1.1 {Tk_ChooseColorObjCmd} -constraints { testwinevent @@ -852,18 +876,17 @@ test winDialog-10.9 {Tk_FontchooserObjCmd: -title} -constraints { set a(text) } -result "Привет" +# +# TESTFILE CLEANUP +# + if {[testConstraint testwinevent]} { catch {testwinevent debug 0} } -# -# CLEANUP -# - unset applyFontCmd initialDir testutils forget dialog cleanupTests -return # Local variables: # mode: tcl diff --git a/tests/winFont.test b/tests/winFont.test index c036313..a42ac9f 100644 --- a/tests/winFont.test +++ b/tests/winFont.test @@ -1,23 +1,41 @@ # This file is a Tcl script to test out the procedures in tkWinFont.c. # It is organized in the standard fashion for Tcl tests. # +# Copyright © 1996-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. +# All rights reserved. + +# NOTE +# # Many of these tests are visually oriented and cannot be checked # programmatically (such as "does an underlined font appear to be # underlined?"); these tests attempt to exercise the code in question, # but there are no results that can be checked. + # -# Copyright © 1996-1997 Sun Microsystems, Inc. -# Copyright © 1998-1999 Scriptics Corporation. -# All rights reserved. +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] -package require tcltest 2.2 -namespace import ::tcltest::* -tcltest::configure {*}$argv -tcltest::loadTestedCommands +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import geometry +# +# TESTS +# + test winfont-1.1 {TkpGetNativeFont procedure: not native} -constraints { win } -body { @@ -111,6 +129,10 @@ test winfont-4.1 {TkpGetFontFamilies procedure} -constraints win -body { set x {} } -result {} +# +# COMMON TEST SETUP +# + destroy .t toplevel .t wm geometry .t +0+0 @@ -381,12 +403,11 @@ test winfont-7.4 {InitFont procedure: extract info from textmetric} -constraints } -result 1 # -# CLEANUP +# TESTFILE CLEANUP # testutils forget geometry cleanupTests -return # Local variables: # mode: tcl diff --git a/tests/winMenu.test b/tests/winMenu.test index 633034e..c0fe557 100644 --- a/tests/winMenu.test +++ b/tests/winMenu.test @@ -1,16 +1,30 @@ -# This file is a Tcl script to test menus in Tk. It is -# organized in the standard fashion for Tcl tests. This -# file tests the Macintosh-specific features of the menu -# system. +# This file is a Tcl script to test menus in Tk. This # file tests the +# features of the menu system that are specific for MS Windows. # # Copyright © 1995-1996 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -tcltest::configure {*}$argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# TESTS +# test winMenu-1.1 {GetNewID} -constraints win -setup { destroy .m1 @@ -1374,12 +1388,13 @@ test winMenu-34.1 {TkpMenuInit called at boot time} -constraints { emptyTest win } -body {} -# cleanup +# +# TESTFILE CLEANUP +# + deleteWindows cleanupTests -return # Local variables: # mode: tcl # End: - diff --git a/tests/winMsgbox.test b/tests/winMsgbox.test index ab5698c..dd72bfa 100644 --- a/tests/winMsgbox.test +++ b/tests/winMsgbox.test @@ -2,13 +2,33 @@ # # Copyright © 2007 Pat Thoyts <patthoyts@users.sourceforge.net> -package require tcltest 2.2 -namespace import ::tcltest::* -tcltest::configure {*}$argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# LOCAL TEST CONSTRAINTS +# testConstraint getwindowinfo [expr {[llength [info command ::testgetwindowinfo]] > 0}] +# +# COMMON TEST SETUP +# + if {[testConstraint testwinevent]} { catch {testwinevent debug 1} } @@ -33,7 +53,9 @@ proc GetWindowInfo {title button} { testwinevent $hwnd $button WM_COMMAND } -# ------------------------------------------------------------------------- +# +# TESTS +# test winMsgbox-1.1 {tk_messageBox ok} -constraints {win getwindowinfo} -setup { wm iconify . @@ -178,7 +200,6 @@ test winMsgbox-1.13 {tk_messageBox yesnocancel} -constraints {win getwindowinfo} wm deiconify . } -result {cancel} -# ------------------------------------------------------------------------- test winMsgbox-2.1 {tk_messageBox message} -constraints {win getwindowinfo} -setup { wm iconify . @@ -245,7 +266,6 @@ test winMsgbox-2.4 {tk_messageBox message (empty)} -constraints { wm deiconify . } -result [list ok ""] -# ------------------------------------------------------------------------- test winMsgbox-3.1 {tk_messageBox detail (sourceforge bug #1692927)} -constraints { win getwindowinfo @@ -282,13 +302,14 @@ test winMsgbox-3.2 {tk_messageBox detail (unicode)} -constraints { wm deiconify . } -result [list ok "Поиск\n\nстраниц"] -# ------------------------------------------------------------------------- +# +# TESTFILE CLEANUP +# if {[testConstraint testwinevent]} { catch {testwinevent debug 0} } cleanupTests -return # Local variables: # mode: tcl diff --git a/tests/winSend.test b/tests/winSend.test index c7426cc..a4ec77c 100644 --- a/tests/winSend.test +++ b/tests/winSend.test @@ -1,20 +1,41 @@ # This file is a Tcl script to test out the "send" command and the -# other procedures in the file tkSend.c. It is organized in the -# standard fashion for Tcl tests. +# other procedures in the file tkSend.c. # # Copyright © 1994 Sun Microsystems, Inc. # Copyright © 1994-1996 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -eval tcltest::configure $argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import child +# +# COMMON TEST SETUP +# + set currentInterps [winfo interps] + +# +# LOCAL TEST CONSTRAINTS +# + if { [testConstraint win] && [llength [info commands send]] && @@ -43,6 +64,10 @@ if { testConstraint winSend 0 } +# +# TESTS +# + # setting up dde server is done when the first interp is created and # cannot be tested very easily. test winSend-1.1 {Tk_SetAppName - changing name of interp} winSend { @@ -370,6 +395,10 @@ test winSend-10.18 {Tk_DDEObjCmd - services} winSend { list [catch {dde services Tk {}} msg] [expr {[lsearch $msg $currentService] >= 0}] } {0 1} +# +# TESTFILE CLEANUP +# + # Get rid of the other app and all of its interps set newInterps [winfo interps] @@ -383,10 +412,5 @@ while {[llength $newInterps] != [llength $currentInterps]} { } } -# -# CLEANUP -# - testutils forget child cleanupTests -return diff --git a/tests/winWm.test b/tests/winWm.test index 999e886..6e24415 100644 --- a/tests/winWm.test +++ b/tests/winWm.test @@ -1,18 +1,30 @@ # This file tests is a Tcl script to test the procedures in the file -# tkWinWm.c. It is organized in the standard fashion for Tcl tests. -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. +# tkWinWm.c. # # Copyright © 1996 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -tcltest::configure {*}$argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# TESTS +# test winWm-1.1 {TkWmMapWindow} -constraints win -setup { destroy .t @@ -563,13 +575,13 @@ test winWm-9.2 "check wm forget for unmapped parent (#3205464,#2967911)" -constr unset -nocomplain winwm92 aid id } -result ok -destroy .t +# +# TESTFILE CLEANUP +# -# cleanup +destroy .t cleanupTests -return # Local variables: # mode: tcl # End: - diff --git a/tests/window.test b/tests/window.test index f25720d..ad95d6d 100644 --- a/tests/window.test +++ b/tests/window.test @@ -1,22 +1,43 @@ # This file is a Tcl script to test the procedures in the file -# tkWindow.c. It is organized in the standard fashion for Tcl tests. +# tkWindow.c. # # Copyright © 1995 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -tcltest::configure {*}$argv -tcltest::loadTestedCommands +# NOTE +# +# This file is woefully incomplete. Right now it only tests +# a few parts of a few procedures in tkWindow.c + +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# COMMON TEST SETUP +# update # Move the mouse out of the way for window-2.1 event generate {} <Motion> -warp 1 -x 640 -y 10 -# XXX This file is woefully incomplete. Right now it only tests -# a few parts of a few procedures in tkWindow.c -# ---------------------------------------------------------------------- +# +# TESTS +# test window-1.1 {Tk_CreateWindowFromPath procedure, parent dead} -setup { destroy .t @@ -374,11 +395,11 @@ test window-5.1 {Tk_MakeWindowExist procedure, stacking order and menubars} -con destroy .t } -result {} +# +# TESTFILE CLEANUP +# - -# cleanup cleanupTests -return # Local variables: # mode: tcl diff --git a/tests/winfo.test b/tests/winfo.test index b19f762..8402338 100644 --- a/tests/winfo.test +++ b/tests/winfo.test @@ -1,23 +1,38 @@ -# This file is a Tcl script to test out the "winfo" command. It is -# organized in the standard fashion for Tcl tests. +# This file is a Tcl script to test out the "winfo" command. # # Copyright © 1994 The Regents of the University of California. # Copyright © 1994-1997 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -tcltest::configure {*}$argv -tcltest::loadTestedCommands +# NOTE +# +# This test file is woefully incomplete. At present, only a +# few of the winfo options are tested. + +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import colors -# XXX - This test file is woefully incomplete. At present, only a -# few of the winfo options are tested. - -# ---------------------------------------------------------------------- +# +# TESTS +# test winfo-1.1 {"winfo atom" command} -body { winfo atom @@ -374,11 +389,6 @@ test winfo-13.1 {root coordinates of embedded toplevel} -setup { # Windows does not destroy the container when an embedded window is # destroyed. Unix and macOS do destroy it. See ticket [67384bce7d]. -if {[tk windowingsystem] eq "win32"} { - set result_13_2 {embedded 0 container 1} -} else { - set result_13_2 {embedded 0 container 0} -} test winfo-13.2 {destroying embedded toplevel} -setup { deleteWindows } -body { @@ -394,7 +404,7 @@ test winfo-13.2 {destroying embedded toplevel} -setup { list embedded [winfo exists .emb.b] container [winfo exists .con] } -cleanup { deleteWindows -} -result $result_13_2 +} -result [expr {[tk windowingsystem] eq "win32"?{embedded 0 container 1}:{embedded 0 container 0}}] test winfo-13.3 {destroying container window} -setup { deleteWindows @@ -463,13 +473,12 @@ test winfo-14.4 {mapped at idle time} -setup { } -result 1 # -# CLEANUP +# TESTFILE CLEANUP # deleteWindows testutils forget colors cleanupTests -return # Local variables: # mode: tcl diff --git a/tests/wm.test b/tests/wm.test index cf1bbd7..140c3ec 100644 --- a/tests/wm.test +++ b/tests/wm.test @@ -1,19 +1,54 @@ # This file is a Tcl script to test out Tk's interactions with the window -# manager, including the "wm" command. It is organized in the standard fashion -# for Tcl tests. +# manager, including the "wm" command. It tests window manager interactions +# that work across platforms. Window manager tests that only work on a specific +# platform should be placed in unixWm.test or winWm.test. # # Copyright © 1992-1994 The Regents of the University of California. # Copyright © 1994-1997 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -# This file tests window manager interactions that work across platforms. -# Window manager tests that only work on a specific platform should be placed -# in unixWm.test or winWm.test. +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows -package require tcltest 2.2 -eval tcltest::configure $argv -tcltest::loadTestedCommands +# +# LOCAL UTILITY PROCS +# + +# [raise] and [lower] may return before the window manager has completed the +# operation. The raiseDelay procedure idles for a while to give the operation +# a chance to complete. +# +proc raiseDelay {} { + after 250; + update idletasks + update +} + +proc stdWindow {} { + destroy .t + toplevel .t -width 100 -height 50 + wm geom .t +0+0 + update +} + +# +# COMMON TEST SETUP +# image create photo icon -data { iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAABGdBTUEAALGPC/xhBQAAA @@ -85,30 +120,13 @@ if {![winfo ismapped .]} { tkwait visibility . } -proc stdWindow {} { - destroy .t - toplevel .t -width 100 -height 50 - wm geom .t +0+0 - update -} - -# [raise] and [lower] may return before the window manager has completed the -# operation. The raiseDelay procedure idles for a while to give the operation -# a chance to complete. -# - -proc raiseDelay {} { - after 250; - update idletasks - update -} - deleteWindows - -############################################################################## - stdWindow +# +# TESTS +# + test wm-1.1 {Tk_WmObjCmd procedure, miscellaneous errors} -returnCodes error -body { wm } -result {wrong # args: should be "wm option window ?arg ...?"} @@ -192,34 +210,19 @@ test wm-attributes-1.2.2 {usage} -constraints win -returnCodes error -body { test wm-attributes-1.2.3 {usage} -constraints win -returnCodes error -body { wm attributes . -to } -result {bad attribute "-to": must be -alpha, -disabled, -fullscreen, -toolwindow, -topmost, or -transparentcolor} -test wm-attributes-1.2.4 {usage} -constraints {unix notAqua} -returnCodes error -body { +test wm-attributes-1.2.5.1 {usage} -constraints x11 -returnCodes error -body { wm attributes . _ } -result {bad attribute "_": must be -alpha, -fullscreen, -topmost, -type, or -zoomed} -if {[tk windowingsystem] eq "aqua"} { - set result_1_2_5 {bad attribute "_": must be -alpha, -appearance, -buttons, -fullscreen, -isdark, -modified, -notify, -titlepath, -topmost, -transparent, -stylemask, -class, -tabbingid, -tabbingmode, or -type} -} else {set result_1_2_5 {bad attribute "_": must be -alpha, -fullscreen, -modified, -notify, -titlepath, -topmost, -transparent, or -type}} -test wm-attributes-1.2.5 {usage} -constraints aqua -returnCodes error -body { +test wm-attributes-1.2.5.2 {usage} -constraints win32 -returnCodes error -body { wm attributes . _ -} -result $result_1_2_5 - -### wm client ### -test wm-client-1.1 {usage} -returnCodes error -body { - wm client -} -result {wrong # args: should be "wm option window ?arg ...?"} -test wm-client-1.2 {usage} -returnCodes error -body { - wm client . _ _ -} -result {wrong # args: should be "wm client window ?name?"} - -test wm-client-2.1 {setting and reading values} -setup { - set result {} -} -body { - lappend result [wm client .t] - wm client .t Miffo - lappend result [wm client .t] - wm client .t {} - lappend result [wm client .t] -} -result [list {} Miffo {}] +} -result {bad attribute "_": must be -alpha, -disabled, -fullscreen, -toolwindow, -topmost, or -transparentcolor} +test wm-attributes-1.2.5.3 {usage} -constraints aqua -returnCodes error -body { + wm attributes . _ +} -result {bad attribute "_": must be -alpha, -appearance, -buttons, -fullscreen, -isdark, -modified, -notify, -titlepath, -topmost, -transparent, -stylemask, -class, -tabbingid, -tabbingmode, or -type} +# +# COMMON TEST CLEANUP +# deleteWindows test wm-attributes-1.3.0 {default -fullscreen value} -constraints win -body { @@ -500,9 +503,31 @@ test wm-attributes-1.5.5 {fullscreen stackorder} -setup { deleteWindows } -result {{. .a .b .c} {. .a .b .c} {. .a .b .c}} +### wm client ### +test wm-client-1.1 {usage} -returnCodes error -body { + wm client +} -result {wrong # args: should be "wm option window ?arg ...?"} +test wm-client-1.2 {usage} -returnCodes error -body { + wm client . _ _ +} -result {wrong # args: should be "wm client window ?name?"} -stdWindow +test wm-client-2.1 {setting and reading values} -setup { + toplevel .t + set result {} +} -body { + lappend result [wm client .t] + wm client .t Miffo + lappend result [wm client .t] + wm client .t {} + lappend result [wm client .t] +} -cleanup { + destroy .t +} -result [list {} Miffo {}] +# +# COMMON TEST SETUP +# +stdWindow ### wm colormapwindows ### test wm-colormapwindows-1.1 {usage} -returnCodes error -body { @@ -609,7 +634,11 @@ test wm-deiconify-1.6 {usage} -constraints !win -setup { destroy .t.f .embed } -result {can't deiconify .embed: it is an embedded window} +# +# COMMON TEST CLEANUP +# deleteWindows + test wm-deiconify-2.1 {a window that has never been mapped\ should not be mapped by a call to deiconify} -body { toplevel .t @@ -667,6 +696,9 @@ test wm-focusmodel-1.3 {usage} -returnCodes error -body { wm focusmodel . bogus } -result {bad argument "bogus": must be active or passive} +# +# COMMON TEST SETUP +# stdWindow test wm-focusmodel-2.1 {setting and reading values} -setup { @@ -892,7 +924,11 @@ test wm-iconify-1.2 {usage} -returnCodes error -body { wm iconify .t _ } -result {wrong # args: should be "wm iconify window"} +# +# COMMON TEST SETUP +# destroy .t2 + test wm-iconify-2.1 {Misc errors} -body { toplevel .t2 wm overrideredirect .t2 1 @@ -1127,7 +1163,11 @@ test wm-maxsize-1.7 {maxsize must be <= screen size} -setup { destroy .t } -result 1 +# +# COMMON TEST CLEANUP +# destroy .t + test wm-maxsize-2.1 {setting the maxsize to a value smaller\ than the current size will resize a toplevel} -body { toplevel .t -width 300 -height 300 @@ -1279,6 +1319,9 @@ test wm-minsize-2.5 {Use min size if window size is not explicitly set\ destroy .t } -result {{250 250} {300 300}} +# +# COMMON TEST SETUP +# stdWindow ### wm overrideredirect ### @@ -1415,6 +1458,9 @@ test wm-sizefrom-2.1 {setting and reading values} { lappend result [wm sizefrom .t] } {{} user program {}} +# +# COMMON TEST CLEANUP +# destroy .t ### wm stackorder ### @@ -1477,6 +1523,10 @@ test wm-stackorder-1.11 {usage, isabove|isbelow toplevels must be mapped} -body } -cleanup { destroy .t } -returnCodes error -result {window ".t" isn't mapped} + +# +# COMMON TEST CLEANUP +# deleteWindows test wm-stackorder-2.1 {stacking order} -body { @@ -1556,6 +1606,9 @@ test wm-stackorder-2.7 {stacking order: no children returns self} -setup { wm stackorder . } -result {.} +# +# COMMON TEST CLEANUP +# deleteWindows test wm-stackorder-3.1 {unmapped toplevel} -constraints {failsOnUbuntu failsOnXQuartz} -body { @@ -1629,6 +1682,10 @@ test wm-stackorder-3.8 {toplevel mapped in idle callback} -body { } -cleanup { destroy .t1 } -result {.} + +# +# COMMON TEST CLEANUP +# deleteWindows test wm-stackorder-4.1 {wm stackorder isabove|isbelow} -body { @@ -1662,6 +1719,10 @@ test wm-stackorder-4.4 {wm stackorder isabove|isbelow} -body { } -cleanup { destroy .t } -result 1 + +# +# COMMON TEST CLEANUP +# deleteWindows test wm-stackorder-5.1 {a menu is not a toplevel} -body { @@ -1724,6 +1785,9 @@ test wm-stackorder-6.1 {An embedded toplevel does not appear in the \ deleteWindows } -result {. .real} +# +# COMMON TEST SETUP +# stdWindow ### wm title ### @@ -1759,7 +1823,12 @@ test wm-transient-1.3 {usage} -returnCodes error -body { catch {destroy .t} ; toplevel .t wm transient foo .t } -result {bad window path name "foo"} + +# +# COMMON TEST CLEANUP +# deleteWindows + test wm-transient-1.4 {usage} -returnCodes error -body { toplevel .top toplevel .subject @@ -2105,7 +2174,11 @@ test wm-state-1.2 {usage} -returnCodes error -body { wm state . _ _ } -result {wrong # args: should be "wm state window ?state?"} +# +# COMMON TEST CLEANUP +# deleteWindows + test wm-state-2.1 {initial state} -body { toplevel .t wm state .t @@ -2258,7 +2331,11 @@ test wm-withdraw-1.2 {usage} -returnCodes error -body { wm withdraw . _ } -result {wrong # args: should be "wm withdraw window"} +# +# COMMON TEST CLEANUP +# deleteWindows + test wm-withdraw-2.1 {Misc errors} -body { toplevel .t toplevel .t2 @@ -2487,19 +2564,14 @@ test wm-forget-2 {bug [e9112ef96e] - [wm forget] doesn't completely} -setup { unset res } -result {pack {} wm {}} -# FIXME: - -# Test delivery of virtual events to the WM. We could check to see if the -# window was raised after a button click for example. This sort of testing may -# not be possible. - -############################################################################## +# +# TESTFILE CLEANUP +# deleteWindows cleanupTests catch {unset results} catch {unset focusin} -return # Local variables: # mode: tcl diff --git a/tests/xmfbox.test b/tests/xmfbox.test index b584aeb..63c8b0a 100644 --- a/tests/xmfbox.test +++ b/tests/xmfbox.test @@ -1,22 +1,33 @@ -# xmfbox.test -- -# -# This file is a Tcl script to test the file dialog that's used -# when the tk_strictMotif flag is set. Because the file dialog -# runs in a modal loop, the only way to test it sufficiently is -# to call the internal Tcl procedures in xmfbox.tcl directly. +# This file is a Tcl script to test the file dialog that's used +# when the tk_strictMotif flag is set. Because the file dialog +# runs in a modal loop, the only way to test it sufficiently is +# to call the internal Tcl procedures in xmfbox.tcl directly. # # Copyright © 1997 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # Contributions from Don Porter, NIST, 2002. (not subject to US copyright) # All rights reserved. -package require tcltest 2.2 -namespace import ::tcltest::* -tcltest::configure {*}$argv -tcltest::loadTestedCommands +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 -set testPWD [pwd] -catch {unset data foo} +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows + +# +# LOCAL UTILITY PROCS +# proc cleanup {} { global testPWD @@ -57,7 +68,16 @@ proc cleanup {} { update } -# ---------------------------------------------------------------------- +# +# COMMON TEST SETUP +# + +set testPWD [pwd] +catch {unset data foo} + +# +# TESTS +# test xmfbox-1.1 {tk::MotifFDialog_Create, -parent switch} -constraints { unix @@ -163,10 +183,12 @@ test xmfbox-2.6 {tk::MotifFDialog_ActivateFList, ~ in file names} -constraints { $::tk::dialog::file::foo(selectFile) [file normalize $tk::Priv(selectFilePath)] } -result "$testPWD ~nosuchuser1 $testPWD/~nosuchuser1" -# cleanup +# +# TESTFILE CLEANUP +# + cleanup cleanupTests -return # Local variables: # mode: tcl diff --git a/unix/Makefile.in b/unix/Makefile.in index 3c2f890..d4cc7aa 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -223,8 +223,8 @@ INSTALL_STRIP_PROGRAM = strip INSTALL_STRIP_LIBRARY = strip -x INSTALL = $(SHELL) $(UNIX_DIR)/install-sh -c -INSTALL_PROGRAM = ${INSTALL} -INSTALL_LIBRARY = ${INSTALL} +INSTALL_PROGRAM = ${INSTALL} -m 755 +INSTALL_LIBRARY = ${INSTALL} -m 755 INSTALL_DATA = ${INSTALL} -m 644 INSTALL_DATA_DIR = ${INSTALL} -d -m 755 @@ -385,8 +385,8 @@ TTK_OBJS = \ ttkInit.o ttkLabel.o ttkLayout.o ttkManager.o ttkNotebook.o \ ttkPanedwindow.o ttkProgress.o ttkScale.o ttkScrollbar.o ttkScroll.o \ ttkSeparator.o ttkSquare.o ttkState.o \ - ttkTagSet.o ttkTheme.o ttkTrace.o ttkTrack.o ttkTreeview.o \ - ttkWidget.o ttkStubInit.o + ttkTagSet.o ttkTheme.o ttkToggleswitch.o ttkTrace.o ttkTrack.o \ + ttkTreeview.o ttkWidget.o ttkStubInit.o STUB_OBJS = tkStubInit.o @@ -495,6 +495,7 @@ TTK_SRCS = \ $(TTK_DIR)/ttkState.c \ $(TTK_DIR)/ttkTagSet.c \ $(TTK_DIR)/ttkTheme.c \ + $(TTK_DIR)/ttkToggleswitch.c \ $(TTK_DIR)/ttkTrace.c \ $(TTK_DIR)/ttkTrack.c \ $(TTK_DIR)/ttkTreeview.c \ @@ -722,10 +723,10 @@ tktest-real: ${TK_STUB_LIB_FILE} test: test-classic test-ttk test-classic: $(TKTEST_EXE) - $(SHELL_ENV) ./$(TKTEST_EXE) $(TEST_DIR)/all.tcl -geometry +0+0 $(TESTFLAGS) + $(SHELL_ENV) ./$(TKTEST_EXE) $(TEST_DIR)/all.tcl $(TESTFLAGS) test-ttk: $(TKTEST_EXE) - $(SHELL_ENV) ./$(TKTEST_EXE) $(TEST_DIR)/ttk/all.tcl -geometry +0+0 \ + $(SHELL_ENV) ./$(TKTEST_EXE) $(TEST_DIR)/ttk/all.tcl \ $(TESTFLAGS) # Tests with different languages @@ -734,7 +735,7 @@ testlang: $(TKTEST_EXE) for lang in $(LOCALES) ; \ do \ LANG=$(lang); export LANG; \ - ./$(TKTEST_EXE) $(TEST_DIR)/all.tcl -geometry +0+0 \ + ./$(TKTEST_EXE) $(TEST_DIR)/all.tcl \ $(TESTFLAGS); \ done @@ -761,7 +762,7 @@ gdb: ${WISH_EXE} VALGRINDARGS=--tool=memcheck --num-callers=8 --leak-resolution=high --leak-check=yes --show-reachable=yes -v valgrind: $(TKTEST_EXE) - $(SHELL_ENV) valgrind $(VALGRINDARGS) ./$(TKTEST_EXE) $(TEST_DIR)/all.tcl -geometry +0+0 -singleproc 1 $(TESTFLAGS) + $(SHELL_ENV) valgrind $(VALGRINDARGS) ./$(TKTEST_EXE) $(TEST_DIR)/all.tcl -singleproc 1 $(TESTFLAGS) valgrindshell: $(TKTEST_EXE) $(SHELL_ENV) valgrind $(VALGRINDARGS) ./$(TKTEST_EXE) $(SCRIPT) @@ -812,10 +813,8 @@ install-binaries: $(TK_STUB_LIB_FILE) $(TK_LIB_FILE) ${WISH_EXE} fi @echo "Installing $(LIB_FILE) to $(DLL_INSTALL_DIR)/" @@INSTALL_LIB@ - @chmod 555 "$(DLL_INSTALL_DIR)/$(LIB_FILE)" @if test -f "tk${MAJOR_VERSION}${MINOR_VERSION}.dll"; then \ $(INSTALL_LIBRARY) "tk${MAJOR_VERSION}${MINOR_VERSION}.dll" "$(DLL_INSTALL_DIR)";\ - chmod 555 "$(DLL_INSTALL_DIR)/tk${MAJOR_VERSION}${MINOR_VERSION}.dll";\ fi @echo "Installing ${WISH_EXE} as $(BIN_INSTALL_DIR)/wish$(VERSION)${EXE_SUFFIX}" @$(INSTALL_PROGRAM) ${WISH_EXE} "$(BIN_INSTALL_DIR)/wish$(VERSION)${EXE_SUFFIX}" @@ -970,7 +969,7 @@ Makefile: $(UNIX_DIR)/Makefile.in clean: rm -rf *.vfs - rm -f *.a *.o libtk* libtcl9tk* core errs *~ \#* TAGS *.E a.out \ + rm -f *.a *.o libtk* libtcl9tk* cygtcl9tk* core errs *~ \#* TAGS *.E a.out \ errors ${WISH_EXE} $(TKTEST_EXE) lib.exp Tk *.rsrc \ *.zip @@ -1424,9 +1423,6 @@ tkMacOSXPrint.o: $(MAC_OSX_DIR)/tkMacOSXPrint.c tkMacOSXRegion.o: $(MAC_OSX_DIR)/tkMacOSXRegion.c $(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tkMacOSXRegion.c -tkMacOSXScale.o: $(MAC_OSX_DIR)/tkMacOSXScale.c - $(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tkMacOSXScale.c - tkMacOSXScrlbr.o: $(MAC_OSX_DIR)/tkMacOSXScrlbr.c $(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tkMacOSXScrlbr.c @@ -1559,6 +1555,9 @@ ttkTagSet.o: $(TTK_DIR)/ttkTagSet.c ttkTheme.o: $(TTK_DIR)/ttkTheme.c $(CC) -c $(CC_SWITCHES) $(TTK_DIR)/ttkTheme.c +ttkToggleswitch.o: $(TTK_DIR)/ttkToggleswitch.c + $(CC) -c $(CC_SWITCHES) $(TTK_DIR)/ttkToggleswitch.c + ttkTrace.o: $(TTK_DIR)/ttkTrace.c $(CC) -c $(CC_SWITCHES) $(TTK_DIR)/ttkTrace.c @@ -1729,8 +1728,7 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tkConfig.h.in $(UNIX_DIR)/tk.pc.in \ $(DISTDIR)/macosx $(DIST_INSTALL_DATA) $(TOP_DIR)/license.terms $(DISTDIR)/macosx $(INSTALL_DATA_DIR) $(DISTDIR)/compat - $(DIST_INSTALL_DATA) $(TOP_DIR)/license.terms \ - $(TOP_DIR)/compat/stdbool.h $(DISTDIR)/compat + $(DIST_INSTALL_DATA) $(TOP_DIR)/license.terms $(DISTDIR)/compat $(INSTALL_DATA_DIR) $(DISTDIR)/xlib $(DIST_INSTALL_DATA) $(XLIB_DIR)/*.[ch] $(DISTDIR)/xlib $(DIST_INSTALL_DATA) $(TOP_DIR)/license.terms $(DISTDIR)/xlib @@ -1778,8 +1776,8 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tkConfig.h.in $(UNIX_DIR)/tk.pc.in \ $(DIST_INSTALL_DATA) $(TOP_DIR)/license.terms $(TOP_DIR)/doc/*.[13n] \ $(TOP_DIR)/doc/man.macros $(DISTDIR)/doc $(INSTALL_DATA_DIR) $(DISTDIR)/tests - $(DIST_INSTALL_DATA) $(TOP_DIR)/license.terms $(TEST_DIR)/*.{test,tcl} \ - $(TEST_DIR)/README $(TEST_DIR)/*.{gif,png,ppm,xbm} \ + $(DIST_INSTALL_DATA) $(TOP_DIR)/license.terms $(TEST_DIR)/testutils.GUIDE \ + $(TEST_DIR)/README $(TEST_DIR)/*.{test,tcl,gif,png,ppm,xbm} \ $(TEST_DIR)/option.file* $(DISTDIR)/tests $(INSTALL_DATA_DIR) $(DISTDIR)/tests/ttk $(DIST_INSTALL_DATA) $(TEST_DIR)/ttk/*.{svg,test,tcl} $(DISTDIR)/tests/ttk diff --git a/unix/configure b/unix/configure index f837abb..38ac8c9 100755 --- a/unix/configure +++ b/unix/configure @@ -2605,7 +2605,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu TK_VERSION=9.1 TK_MAJOR_VERSION=9 TK_MINOR_VERSION=1 -TK_PATCH_LEVEL="a0" +TK_PATCH_LEVEL="a1" VERSION=${TK_VERSION} LOCALES="cs da de el en en_gb eo es fr hu it nl pl pt ru sv" @@ -6366,15 +6366,6 @@ printf "%s\n" "$tcl_cv_cc_input_charset" >&6; } CFLAGS="$CFLAGS -finput-charset=UTF-8" fi - ac_fn_c_check_header_compile "$LINENO" "stdbool.h" "ac_cv_header_stdbool_h" "$ac_includes_default" -if test "x$ac_cv_header_stdbool_h" = xyes -then : - -printf "%s\n" "#define HAVE_STDBOOL_H 1" >>confdefs.h - -fi - - # Check for vfork, posix_spawnp() and friends unconditionally ac_fn_c_check_func "$LINENO" "vfork" "ac_cv_func_vfork" if test "x$ac_cv_func_vfork" = xyes @@ -7763,9 +7754,6 @@ if test $tk_aqua = yes; then printf "%s\n" "#define MAC_OSX_TK 1" >>confdefs.h LIBS="$LIBS -framework Cocoa -framework Carbon -framework IOKit -framework QuartzCore -framework Security -framework CoreGraphics" - if test -d /System/Library/Frameworks/UserNotifications.framework; then - LIBS="$LIBS -framework UserNotifications" - fi if test -d "/System/Library/Frameworks/UniformTypeIdentifiers.framework"; then LIBS="$LIBS -weak_framework UniformTypeIdentifiers" fi @@ -9046,8 +9034,9 @@ fi MACHER_PROG="$ac_cv_path_macher" { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $MACHER_PROG" >&5 printf "%s\n" "$MACHER_PROG" >&6; } - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: Found macher in environment" >&5 -printf "%s\n" "Found macher in environment" >&6; } + else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: Macher not found" >&5 +printf "%s\n" "Macher not found" >&6; } fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for zip" >&5 printf %s "checking for zip... " >&6; } @@ -9078,8 +9067,6 @@ fi printf "%s\n" "$ZIP_PROG" >&6; } ZIP_PROG_OPTIONS="-rq" ZIP_PROG_VFSSEARCH="*" - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: Found INFO Zip in environment" >&5 -printf "%s\n" "Found INFO Zip in environment" >&6; } # Use standard arguments for zip else # It is not an error if an installed version of Zip can't be located. diff --git a/unix/configure.ac b/unix/configure.ac index d8e1873..7a9f7c0 100644 --- a/unix/configure.ac +++ b/unix/configure.ac @@ -26,7 +26,7 @@ m4_ifdef([SC_USE_CONFIG_HEADERS], [ TK_VERSION=9.1 TK_MAJOR_VERSION=9 TK_MINOR_VERSION=1 -TK_PATCH_LEVEL="a0" +TK_PATCH_LEVEL="a1" VERSION=${TK_VERSION} LOCALES="cs da de el en en_gb eo es fr hu it nl pl pt ru sv" @@ -241,9 +241,6 @@ fi if test $tk_aqua = yes; then AC_DEFINE(MAC_OSX_TK, 1, [Are we building TkAqua?]) LIBS="$LIBS -framework Cocoa -framework Carbon -framework IOKit -framework QuartzCore -framework Security -framework CoreGraphics" - if test -d /System/Library/Frameworks/UserNotifications.framework; then - LIBS="$LIBS -framework UserNotifications" - fi if test -d "/System/Library/Frameworks/UniformTypeIdentifiers.framework"; then LIBS="$LIBS -weak_framework UniformTypeIdentifiers" fi diff --git a/unix/tcl.m4 b/unix/tcl.m4 index dbe61c5..3a2ddfc 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1862,8 +1862,6 @@ dnl # preprocessing tests use only CPPFLAGS. CFLAGS="$CFLAGS -finput-charset=UTF-8" fi - AC_CHECK_HEADER(stdbool.h, [AC_DEFINE(HAVE_STDBOOL_H, 1, [Do we have <stdbool.h>?])],) - # Check for vfork, posix_spawnp() and friends unconditionally AC_CHECK_FUNCS(vfork posix_spawnp posix_spawn_file_actions_adddup2 posix_spawnattr_setflags) @@ -2258,9 +2256,6 @@ AC_DEFUN([SC_TCL_LINK_LIBS], [ LIBS="$LIBS $THREADS_LIBS" AC_CHECK_FUNCS(pthread_attr_setstacksize pthread_atfork) LIBS=$ac_saved_libs - - # TIP #509 - AC_CHECK_DECLS([PTHREAD_MUTEX_RECURSIVE],tcl_ok=yes,tcl_ok=no, [[#include <pthread.h>]]) ]) #-------------------------------------------------------------------- @@ -3001,7 +2996,8 @@ AC_DEFUN([SC_ZIPFS_SUPPORT], [ if test -f "$ac_cv_path_macher" ; then MACHER_PROG="$ac_cv_path_macher" AC_MSG_RESULT([$MACHER_PROG]) - AC_MSG_RESULT([Found macher in environment]) + else + AC_MSG_RESULT([Macher not found]) fi AC_MSG_CHECKING([for zip]) AC_CACHE_VAL(ac_cv_path_zip, [ @@ -3023,7 +3019,6 @@ AC_DEFUN([SC_ZIPFS_SUPPORT], [ AC_MSG_RESULT([$ZIP_PROG]) ZIP_PROG_OPTIONS="-rq" ZIP_PROG_VFSSEARCH="*" - AC_MSG_RESULT([Found INFO Zip in environment]) # Use standard arguments for zip else # It is not an error if an installed version of Zip can't be located. diff --git a/unix/tk.spec b/unix/tk.spec index 3a096fe..9453bad 100644 --- a/unix/tk.spec +++ b/unix/tk.spec @@ -4,7 +4,7 @@ Name: tk Summary: Tk graphical toolkit for the Tcl scripting language. -Version: 9.1a0 +Version: 9.1a1 Release: 2 License: BSD Group: Development/Languages diff --git a/unix/tkConfig.h.in b/unix/tkConfig.h.in index 695fb3a..84c93e5 100644 --- a/unix/tkConfig.h.in +++ b/unix/tkConfig.h.in @@ -46,9 +46,6 @@ /* Does struct password have a pw_gecos field? */ #undef HAVE_PW_GECOS -/* Do we have <stdbool.h>? */ -#undef HAVE_STDBOOL_H - /* Define to 1 if you have the <stdint.h> header file. */ #undef HAVE_STDINT_H diff --git a/unix/tkUnix.c b/unix/tkUnix.c index 1c61603..a687156 100644 --- a/unix/tkUnix.c +++ b/unix/tkUnix.c @@ -201,9 +201,9 @@ TkpBuildRegionFromAlphaData( lineDataPtr += pixelStride; } if (end > x1) { - rect.x = x + x1; - rect.y = y + y1; - rect.width = end - x1; + rect.x = (short)(x + x1); + rect.y = (short)(y + y1); + rect.width = (unsigned short)(end - x1); rect.height = 1; TkUnionRectWithRegion(&rect, region, region); } @@ -261,7 +261,7 @@ Tk_GetUserInactiveTime( Tcl_Panic("Out of memory: XScreenSaverAllocInfo failed in Tk_GetUserInactiveTime"); } if (XScreenSaverQueryInfo(dpy, DefaultRootWindow(dpy), info)) { - inactiveTime = info->idle; + inactiveTime = (long)info->idle; } XFree(info); } diff --git a/unix/tkUnixColor.c b/unix/tkUnixColor.c index 20149a3..300275b 100644 --- a/unix/tkUnixColor.c +++ b/unix/tkUnixColor.c @@ -119,7 +119,7 @@ TkpFreeColor( TkColor * TkpGetColor( Tk_Window tkwin, /* Window in which color will be used. */ - Tk_Uid name) /* Name of color to allocated (in form + const char *name) /* Name of color to allocated (in form * suitable for passing to XParseColor). */ { Display *display = Tk_Display(tkwin); diff --git a/unix/tkUnixCursor.c b/unix/tkUnixCursor.c index 073bae4..4fe4f0f 100644 --- a/unix/tkUnixCursor.c +++ b/unix/tkUnixCursor.c @@ -277,7 +277,7 @@ TkGetCursorByName( if (TkParseColor(display, Tk_Colormap(tkwin), argv[1], &fg) == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid color name \"%s\"", argv[1])); - Tcl_SetErrorCode(interp, "TK", "CURSOR", "COLOR", NULL); + Tcl_SetErrorCode(interp, "TK", "CURSOR", "COLOR", (char *)NULL); goto cleanup; } if (argc == 2) { @@ -287,7 +287,7 @@ TkGetCursorByName( &bg) == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid color name \"%s\"", argv[2])); - Tcl_SetErrorCode(interp, "TK", "CURSOR", "COLOR", NULL); + Tcl_SetErrorCode(interp, "TK", "CURSOR", "COLOR", (char *)NULL); goto cleanup; } } @@ -297,7 +297,7 @@ TkGetCursorByName( if (dispPtr->cursorFont == None) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "couldn't load cursor font", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "CURSOR", "FONT", NULL); + Tcl_SetErrorCode(interp, "TK", "CURSOR", "FONT", (char *)NULL); goto cleanup; } } @@ -313,7 +313,7 @@ TkGetCursorByName( Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot get cursor from a file in a safe interpreter", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "SAFE", "CURSOR_FILE", NULL); + Tcl_SetErrorCode(interp, "TK", "SAFE", "CURSOR_FILE", (char *)NULL); cursorPtr = NULL; goto cleanup; } @@ -354,7 +354,7 @@ TkGetCursorByName( ckfree(argv); } Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad cursor spec \"%s\"", string)); - Tcl_SetErrorCode(interp, "TK", "VALUE", "CURSOR", NULL); + Tcl_SetErrorCode(interp, "TK", "VALUE", "CURSOR", (char *)NULL); return NULL; } @@ -428,7 +428,7 @@ CreateCursorFromTableOrFile( if (data == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "error reading bitmap data for \"%s\"", argv[0])); - Tcl_SetErrorCode(interp, "TK", "CURSOR", "BITMAP_DATA", NULL); + Tcl_SetErrorCode(interp, "TK", "CURSOR", "BITMAP_DATA", (char *)NULL); goto cleanup; } @@ -440,7 +440,7 @@ CreateCursorFromTableOrFile( &source, &xHot, &yHot) != BitmapSuccess) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "cleanup reading bitmap file \"%s\"", &argv[0][1])); - Tcl_SetErrorCode(interp, "TK", "CURSOR", "BITMAP_FILE", NULL); + Tcl_SetErrorCode(interp, "TK", "CURSOR", "BITMAP_FILE", (char *)NULL); goto cleanup; } } @@ -453,7 +453,7 @@ CreateCursorFromTableOrFile( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad hot spot in bitmap file \"%s\"", &argv[0][1])); } - Tcl_SetErrorCode(interp, "TK", "CURSOR", "HOTSPOT", NULL); + Tcl_SetErrorCode(interp, "TK", "CURSOR", "HOTSPOT", (char *)NULL); goto cleanup; } @@ -469,7 +469,7 @@ CreateCursorFromTableOrFile( if (TkParseColor(display, Tk_Colormap(tkwin), fgColor, &fg) == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid color name \"%s\"", fgColor)); - Tcl_SetErrorCode(interp, "TK", "CURSOR", "COLOR", NULL); + Tcl_SetErrorCode(interp, "TK", "CURSOR", "COLOR", (char *)NULL); goto cleanup; } if (inTkTable) { @@ -489,13 +489,13 @@ CreateCursorFromTableOrFile( if (TkParseColor(display, Tk_Colormap(tkwin), fgColor, &fg) == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid color name \"%s\"", fgColor)); - Tcl_SetErrorCode(interp, "TK", "CURSOR", "COLOR", NULL); + Tcl_SetErrorCode(interp, "TK", "CURSOR", "COLOR", (char *)NULL); goto cleanup; } if (TkParseColor(display, Tk_Colormap(tkwin), bgColor, &bg) == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid color name \"%s\"", bgColor)); - Tcl_SetErrorCode(interp, "TK", "CURSOR", "COLOR", NULL); + Tcl_SetErrorCode(interp, "TK", "CURSOR", "COLOR", (char *)NULL); goto cleanup; } } @@ -526,7 +526,7 @@ CreateCursorFromTableOrFile( if (data == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "error reading bitmap mask data for \"%s\"", argv[0])); - Tcl_SetErrorCode(interp, "TK", "CURSOR", "MASK_DATA", NULL); + Tcl_SetErrorCode(interp, "TK", "CURSOR", "MASK_DATA", (char *)NULL); goto cleanup; } @@ -540,7 +540,7 @@ CreateCursorFromTableOrFile( &mask, &dummy1, &dummy2) != BitmapSuccess) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "cleanup reading bitmap file \"%s\"", argv[1])); - Tcl_SetErrorCode(interp, "TK", "CURSOR", "MASK_FILE", NULL); + Tcl_SetErrorCode(interp, "TK", "CURSOR", "MASK_FILE", (char *)NULL); goto cleanup; } } @@ -548,7 +548,7 @@ CreateCursorFromTableOrFile( if ((maskWidth != width) || (maskHeight != height)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "source and mask bitmaps have different sizes", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "CURSOR", "SIZE_MATCH", NULL); + Tcl_SetErrorCode(interp, "TK", "CURSOR", "SIZE_MATCH", (char *)NULL); goto cleanup; } diff --git a/unix/tkUnixDraw.c b/unix/tkUnixDraw.c index fe1dea0..ead6c41 100644 --- a/unix/tkUnixDraw.c +++ b/unix/tkUnixDraw.c @@ -137,10 +137,10 @@ ScrollRestrictProc( if (eventPtr->type == NoExpose) { info->done = 1; } else if (eventPtr->type == GraphicsExpose) { - rect.x = eventPtr->xgraphicsexpose.x; - rect.y = eventPtr->xgraphicsexpose.y; - rect.width = eventPtr->xgraphicsexpose.width; - rect.height = eventPtr->xgraphicsexpose.height; + rect.x = (short)eventPtr->xgraphicsexpose.x; + rect.y = (short)eventPtr->xgraphicsexpose.y; + rect.width = (unsigned short)eventPtr->xgraphicsexpose.width; + rect.height = (unsigned short)eventPtr->xgraphicsexpose.height; XUnionRectWithRegion(&rect, info->region, info->region); @@ -156,14 +156,14 @@ ScrollRestrictProc( * area as damaged. */ - rect.x = eventPtr->xexpose.x; - rect.y = eventPtr->xexpose.y; - rect.width = eventPtr->xexpose.width; - rect.height = eventPtr->xexpose.height; + rect.x = (short)eventPtr->xexpose.x; + rect.y = (short)eventPtr->xexpose.y; + rect.width = (unsigned short)eventPtr->xexpose.width; + rect.height = (unsigned short)eventPtr->xexpose.height; XUnionRectWithRegion(&rect, info->region, info->region); - rect.x += info->dx; - rect.y += info->dy; + rect.x += (short)info->dx; + rect.y += (short)info->dy; XUnionRectWithRegion(&rect, info->region, info->region); } else { diff --git a/unix/tkUnixEmbed.c b/unix/tkUnixEmbed.c index a8765bd..965cbae 100644 --- a/unix/tkUnixEmbed.c +++ b/unix/tkUnixEmbed.c @@ -112,7 +112,7 @@ Tk_UseWindow( if (winPtr->window != None) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "can't modify container after widget is created", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "EMBED", "POST_CREATE", NULL); + Tcl_SetErrorCode(interp, "TK", "EMBED", "POST_CREATE", (char *)NULL); return TCL_ERROR; } if (TkpScanWindowId(interp, string, &parent) != TCL_OK) { @@ -124,7 +124,7 @@ Tk_UseWindow( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "window \"%s\" doesn't have -container option set", usePtr->pathName)); - Tcl_SetErrorCode(interp, "TK", "EMBED", "CONTAINER", NULL); + Tcl_SetErrorCode(interp, "TK", "EMBED", "CONTAINER", (char *)NULL); return TCL_ERROR; } @@ -147,7 +147,7 @@ Tk_UseWindow( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't create child of window \"%s\"", string)); - Tcl_SetErrorCode(interp, "TK", "EMBED", "NO_TARGET", NULL); + Tcl_SetErrorCode(interp, "TK", "EMBED", "NO_TARGET", (char *)NULL); } return TCL_ERROR; } @@ -1129,7 +1129,7 @@ TkpMakeTransparentWindowExist( Window parent) /* Parent window. */ { TkWindow *winPtr = (TkWindow *) tkwin; - long int mask = CWDontPropagate | CWEventMask; + unsigned long mask = CWDontPropagate | CWEventMask; /* * Ignore the important events while the window is mapped. diff --git a/unix/tkUnixEvent.c b/unix/tkUnixEvent.c index 5e2c0fa..ae60692 100644 --- a/unix/tkUnixEvent.c +++ b/unix/tkUnixEvent.c @@ -184,13 +184,13 @@ TkpOpenDisplay( if (WidthMMOfScreen(DefaultScreenOfDisplay(display)) <= 0) { int mm; - mm = WidthOfScreen(DefaultScreenOfDisplay(display)) * (25.4 / 75.0); + mm = (int)(WidthOfScreen(DefaultScreenOfDisplay(display)) * (25.4 / 75.0)); WidthMMOfScreen(DefaultScreenOfDisplay(display)) = mm; } if (HeightMMOfScreen(DefaultScreenOfDisplay(display)) <= 0) { int mm; - mm = HeightOfScreen(DefaultScreenOfDisplay(display)) * (25.4 / 75.0); + mm = (int)(HeightOfScreen(DefaultScreenOfDisplay(display)) * (25.4 / 75.0)); HeightMMOfScreen(DefaultScreenOfDisplay(display)) = mm; } @@ -592,8 +592,8 @@ TkUnixDoOneXEvent( blockTime.tv_usec = 0; } fd = ConnectionNumber(dispPtr->display); - index = fd/(NBBY*sizeof(fd_mask)); - bit = ((fd_mask)1) << (fd%(NBBY*sizeof(fd_mask))); + index = fd/(NBBY*(int)sizeof(fd_mask)); + bit = ((fd_mask)1) << (fd%(NBBY*(int)sizeof(fd_mask))); readMask[index] |= bit; if (numFdBits <= fd) { numFdBits = fd+1; @@ -618,8 +618,8 @@ TkUnixDoOneXEvent( for (dispPtr = TkGetDisplayList(); dispPtr != NULL; dispPtr = dispPtr->nextPtr) { fd = ConnectionNumber(dispPtr->display); - index = fd/(NBBY*sizeof(fd_mask)); - bit = ((fd_mask)1) << (fd%(NBBY*sizeof(fd_mask))); + index = fd/(NBBY*(int)sizeof(fd_mask)); + bit = ((fd_mask)1) << (fd%(NBBY*(int)sizeof(fd_mask))); if ((readMask[index] & bit) || (QLength(dispPtr->display) > 0)) { DisplayFileProc(dispPtr, TCL_READABLE); } diff --git a/unix/tkUnixFocus.c b/unix/tkUnixFocus.c index 7ab6e3e..5cae99a 100644 --- a/unix/tkUnixFocus.c +++ b/unix/tkUnixFocus.c @@ -34,7 +34,7 @@ *---------------------------------------------------------------------- */ -int +size_t TkpChangeFocus( TkWindow *winPtr, /* Window that is to receive the X focus. */ int force) /* Non-zero means claim the focus even if it @@ -44,7 +44,8 @@ TkpChangeFocus( TkDisplay *dispPtr = winPtr->dispPtr; Tk_ErrorHandler errHandler; Window window, root, parent, *children; - unsigned int numChildren, serial; + unsigned int numChildren; + size_t serial; TkWindow *winPtr2; int dummy; diff --git a/unix/tkUnixInt.h b/unix/tkUnixInt.h index f46212e..b6a739e 100644 --- a/unix/tkUnixInt.h +++ b/unix/tkUnixInt.h @@ -22,7 +22,7 @@ * they're defined in. */ -#include "tkIntPlatDecls.h" +#include "tkIntPlatDecls.h" /* IWYU pragma: export */ MODULE_SCOPE int Tktray_Init (Tcl_Interp* interp); MODULE_SCOPE int SysNotify_Init (Tcl_Interp* interp); diff --git a/unix/tkUnixPort.h b/unix/tkUnixPort.h index af79850..02f9bd3 100644 --- a/unix/tkUnixPort.h +++ b/unix/tkUnixPort.h @@ -97,7 +97,7 @@ # define NBBY 8 #endif -#include "tkIntXlibDecls.h" +#include "tkIntXlibDecls.h" /* IWYU pragma: export */ #define UINT unsigned int #define HWND void * #define HDC void * diff --git a/unix/tkUnixPrint.c b/unix/tkUnixPrint.c index 978b58f..bf89865 100644 --- a/unix/tkUnixPrint.c +++ b/unix/tkUnixPrint.c @@ -15,7 +15,7 @@ #ifdef HAVE_CUPS #include <cups/cups.h> -typedef int (CupsSubCmdOp)(Tcl_Interp *, int, Tcl_Obj *const []); +typedef int (CupsSubCmdOp)(Tcl_Interp *, Tcl_Size, Tcl_Obj *const []); static Tcl_ObjCmdProc2 Cups_Cmd; static CupsSubCmdOp DefaultPrinterOp; @@ -85,7 +85,7 @@ Cups_Cmd( static int DefaultPrinterOp( Tcl_Interp *interp, - TCL_UNUSED(int), + TCL_UNUSED(Tcl_Size), TCL_UNUSED(Tcl_Obj *const *)) { cups_dest_t *printer; @@ -109,7 +109,7 @@ DefaultPrinterOp( static int GetPrintersOp( Tcl_Interp *interp, - int objc, + Tcl_Size objc, Tcl_Obj *const objv[]) { cups_dest_t *dests; @@ -197,7 +197,7 @@ static const struct ParseData { static int PrintOp( Tcl_Interp *interp, - int objc, + Tcl_Size objc, Tcl_Obj *const objv[]) { cups_dest_t *printer; diff --git a/unix/tkUnixRFont.c b/unix/tkUnixRFont.c index 64be894..31b12a6 100644 --- a/unix/tkUnixRFont.c +++ b/unix/tkUnixRFont.c @@ -1098,7 +1098,7 @@ TkDrawAngledChars( int originX, originY; if (fontPtr->ftDraw == 0) { - DEBUG(("Switch to drawable 0x%x\n", drawable)); + DEBUG(("Switch to drawable 0x%lx\n", drawable)); fontPtr->ftDraw = XftDrawCreate(display, drawable, DefaultVisual(display, fontPtr->screen), DefaultColormap(display, fontPtr->screen)); diff --git a/unix/tkUnixSelect.c b/unix/tkUnixSelect.c index 13c2b30..e8d0922 100644 --- a/unix/tkUnixSelect.c +++ b/unix/tkUnixSelect.c @@ -583,7 +583,7 @@ TkSelEventProc( if (bytesAfter != 0) { Tcl_SetObjResult(retrPtr->interp, Tcl_NewStringObj( "selection property too large", TCL_INDEX_NONE)); - Tcl_SetErrorCode(retrPtr->interp, "TK", "SELECTION", "SIZE",NULL); + Tcl_SetErrorCode(retrPtr->interp, "TK", "SELECTION", "SIZE", (char *)NULL); retrPtr->result = TCL_ERROR; XFree(propInfo); return; @@ -762,7 +762,7 @@ SelTimeoutProc( Tcl_SetObjResult(retrPtr->interp, Tcl_NewStringObj( "selection owner didn't respond", TCL_INDEX_NONE)); - Tcl_SetErrorCode(retrPtr->interp, "TK", "SELECTION", "IGNORED", NULL); + Tcl_SetErrorCode(retrPtr->interp, "TK", "SELECTION", "IGNORED", (char *)NULL); retrPtr->result = TCL_ERROR; } else { retrPtr->timeout = Tcl_CreateTimerHandler(1000, SelTimeoutProc, @@ -1150,7 +1150,7 @@ SelRcvIncrProc( if (bytesAfter != 0) { Tcl_SetObjResult(retrPtr->interp, Tcl_NewStringObj( "selection property too large", TCL_INDEX_NONE)); - Tcl_SetErrorCode(retrPtr->interp, "TK", "SELECTION", "SIZE", NULL); + Tcl_SetErrorCode(retrPtr->interp, "TK", "SELECTION", "SIZE", (char *)NULL); retrPtr->result = TCL_ERROR; goto done; } diff --git a/unix/tkUnixSend.c b/unix/tkUnixSend.c index 9d4d570..762c2e8 100644 --- a/unix/tkUnixSend.c +++ b/unix/tkUnixSend.c @@ -961,7 +961,8 @@ Tk_SendObjCmd( Window commWindow; PendingCommand pending; RegisteredInterp *riPtr; - int result, async, i, firstArg, index; + int result, async, index; + Tcl_Size i, firstArg; Tk_RestrictProc *prevProc; void *prevArg; TkDisplay *dispPtr; diff --git a/unix/tkUnixSysTray.c b/unix/tkUnixSysTray.c index 9c087ba..8776d95 100644 --- a/unix/tkUnixSysTray.c +++ b/unix/tkUnixSysTray.c @@ -301,8 +301,9 @@ TrayIconObjectCmd( return TCL_ERROR; } if (objc == 4) { - if (Tcl_GetLongFromObj(interp,objv[3],&timeout) != TCL_OK) + if (Tcl_GetLongFromObj(interp,objv[3],&timeout) != TCL_OK) { return TCL_ERROR; + } } msgid = PostBalloon(icon,Tcl_GetString(objv[2]), timeout); Tcl_SetObjResult(interp,Tcl_NewIntObj(msgid)); @@ -316,8 +317,9 @@ TrayIconObjectCmd( if (Tcl_GetIntFromObj(interp,objv[2],&msgid) != TCL_OK) { return TCL_ERROR; } - if (msgid) + if (msgid) { CancelBalloon(icon,msgid); + } return TCL_OK; case XWC_BBOX: @@ -1016,8 +1018,9 @@ RetargetEvent( { int send = 0; Window* saveWin1 = NULL, *saveWin2 = NULL; - if (!icon->visible) + if (!icon->visible) { return; + } switch (ev->type) { case MotionNotify: send = 1; @@ -1092,8 +1095,9 @@ TrayIconWrapperEvent( if (icon->drawingWin) { /* we were sent away to root */ TKU_WmWithdraw(icon->drawingWin,icon->interp); - if (icon->myManager) + if (icon->myManager) { Tk_SendVirtualEvent(icon->tkwin,Tk_GetUid("IconDestroy"), NULL); + } icon->myManager = None; } } /* Reparenting into some other embedder is theoretically possible, @@ -1129,8 +1133,9 @@ TrayIconEvent( switch (ev->type) { case Expose: - if (!ev->xexpose.count) + if (!ev->xexpose.count) { EventuallyRedrawIcon(icon); + } break; case DestroyNotify: @@ -1261,12 +1266,14 @@ PostBalloon( int length = strlen(utf8msg); XEvent ev; - if (!(icon->drawingWin) || (icon->myManager == None)) + if (!(icon->drawingWin) || (icon->myManager == None)) { return 0; + } /* overflow protection */ - if (icon->msgid < 0) + if (icon->msgid < 0) { icon->msgid = 0; + } memset(&ev, 0, sizeof(ev)); ev.xclient.type = ClientMessage; @@ -1324,11 +1331,13 @@ CancelBalloon( Display* dpy = Tk_Display(tkwin); XEvent ev; - if (!(icon->drawingWin) || (icon->myManager == None)) + if (!(icon->drawingWin) || (icon->myManager == None)) { return; + } /* overflow protection */ - if (icon->msgid < 0) + if (icon->msgid < 0) { icon->msgid = 0; + } memset(&ev, 0, sizeof(ev)); ev.type = ClientMessage; @@ -1372,8 +1381,9 @@ IconGenericHandler( ((Atom)ev->xclient.data.l[1] == icon->a_NET_SYSTEM_TRAY_Sn)) { icon->trayManager = (Window)ev->xclient.data.l[2]; XSelectInput(ev->xclient.display,icon->trayManager,StructureNotifyMask); - if (icon->myManager == None) + if (icon->myManager == None) { TrayIconUpdate(icon, ICON_CONF_XEMBED); + } return 1; } if (ev->type == DestroyNotify) { @@ -1417,8 +1427,9 @@ TrayIconUpdate( * anyway, let's handle it if we provide it. */ if (mask & ICON_CONF_CLASS) { - if (icon->drawingWin) + if (icon->drawingWin) { Tk_SetClass(icon->drawingWin,Tk_GetUid(Tcl_GetString(icon->classObj))); + } } /* * First, ensure right icon visibility. diff --git a/unix/tkUnixWm.c b/unix/tkUnixWm.c index 41dc5e3..b9ce1ca 100644 --- a/unix/tkUnixWm.c +++ b/unix/tkUnixWm.c @@ -1225,7 +1225,7 @@ WmAspectCmd( (denom2 <= 0)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "aspect number can't be <= 0", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "VALUE", "ASPECT", NULL); + Tcl_SetErrorCode(interp, "TK", "VALUE", "ASPECT", (char *)NULL); return TCL_ERROR; } wmPtr->minAspect.x = numer1; @@ -1724,14 +1724,14 @@ WmDeiconifyCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't deiconify %s: it is an icon for %s", Tcl_GetString(objv[2]), Tk_PathName(wmPtr->iconFor))); - Tcl_SetErrorCode(interp, "TK", "WM", "DEICONIFY", "ICON", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "DEICONIFY", "ICON", (char *)NULL); return TCL_ERROR; } if (winPtr->flags & TK_EMBEDDED) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't deiconify %s: it is an embedded window", winPtr->pathName)); - Tcl_SetErrorCode(interp, "TK", "WM", "DEICONIFY", "EMBEDDED", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "DEICONIFY", "EMBEDDED", (char *)NULL); return TCL_ERROR; } wmPtr->flags &= ~WM_WITHDRAWN; @@ -2019,25 +2019,25 @@ WmGridCmd( if (reqWidth < 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "baseWidth can't be < 0", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "VALUE", "GRID", NULL); + Tcl_SetErrorCode(interp, "TK", "VALUE", "GRID", (char *)NULL); return TCL_ERROR; } if (reqHeight < 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "baseHeight can't be < 0", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "VALUE", "GRID", NULL); + Tcl_SetErrorCode(interp, "TK", "VALUE", "GRID", (char *)NULL); return TCL_ERROR; } if (widthInc <= 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "widthInc can't be <= 0", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "VALUE", "GRID", NULL); + Tcl_SetErrorCode(interp, "TK", "VALUE", "GRID", (char *)NULL); return TCL_ERROR; } if (heightInc <= 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "heightInc can't be <= 0", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "VALUE", "GRID", NULL); + Tcl_SetErrorCode(interp, "TK", "VALUE", "GRID", (char *)NULL); return TCL_ERROR; } Tk_SetGrid((Tk_Window) winPtr, reqWidth, reqHeight, widthInc, @@ -2268,27 +2268,27 @@ WmIconifyCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't iconify \"%s\": it is a transient", winPtr->pathName)); - Tcl_SetErrorCode(interp, "TK", "WM", "ICONIFY", "TRANSIENT", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "ICONIFY", "TRANSIENT", (char *)NULL); return TCL_ERROR; } if (wmPtr->iconFor != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't iconify \"%s\": it is an icon for \"%s\"", winPtr->pathName, Tk_PathName(wmPtr->iconFor))); - Tcl_SetErrorCode(interp, "TK", "WM", "ICONIFY", "ICON", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "ICONIFY", "ICON", (char *)NULL); return TCL_ERROR; } if (winPtr->flags & TK_EMBEDDED) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't iconify \"%s\": it is an embedded window", winPtr->pathName)); - Tcl_SetErrorCode(interp, "TK", "WM", "ICONIFY", "EMBEDDED", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "ICONIFY", "EMBEDDED", (char *)NULL); return TCL_ERROR; } if (TkpWmSetState(winPtr, IconicState) == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "couldn't send iconify message to window manager", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "WM", "COMMUNICATION", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "COMMUNICATION", (char *)NULL); return TCL_ERROR; } return TCL_OK; @@ -2461,7 +2461,7 @@ WmIconphotoCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't use \"%s\" as iconphoto: not a photo image", Tcl_GetString(objv[i]))); - Tcl_SetErrorCode(interp, "TK", "WM", "ICONPHOTO", "PHOTO", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "ICONPHOTO", "PHOTO", (char *)NULL); return TCL_ERROR; } Tk_PhotoGetSize(photo, &width, &height); @@ -2494,7 +2494,7 @@ WmIconphotoCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "failed to create an iconphoto with image \"%s\"", Tcl_GetString(objv[i]))); - Tcl_SetErrorCode(interp, "TK", "WM", "ICONPHOTO", "IMAGE", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "ICONPHOTO", "IMAGE", (char *)NULL); return TCL_ERROR; } Tk_PhotoGetSize(photo, &width, &height); @@ -2678,7 +2678,7 @@ WmIconwindowCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't use %s as icon window: not at top level", Tcl_GetString(objv[3]))); - Tcl_SetErrorCode(interp, "TK", "WM", "ICONWINDOW", "INNER", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "ICONWINDOW", "INNER", (char *)NULL); return TCL_ERROR; } wmPtr2 = ((TkWindow *) tkwin2)->wmInfoPtr; @@ -2686,7 +2686,7 @@ WmIconwindowCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s is already an icon for %s", Tcl_GetString(objv[3]), Tk_PathName(wmPtr2->iconFor))); - Tcl_SetErrorCode(interp, "TK", "WM", "ICONWINDOW", "ICON", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "ICONWINDOW", "ICON", (char *)NULL); return TCL_ERROR; } if (wmPtr->icon != NULL) { @@ -2722,7 +2722,7 @@ WmIconwindowCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "couldn't send withdraw message to window manager", -1)); - Tcl_SetErrorCode(interp, "TK", "WM", "COMMUNICATION", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "COMMUNICATION", (char *)NULL); return TCL_ERROR; } WaitForMapNotify((TkWindow *) tkwin2, 0); @@ -2765,7 +2765,7 @@ WmManageCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "window \"%s\" is not manageable: must be a frame," " labelframe or toplevel", Tk_PathName(frameWin))); - Tcl_SetErrorCode(interp, "TK", "WM", "MANAGE", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "MANAGE", (char *)NULL); return TCL_ERROR; } TkFocusSplit(winPtr); @@ -3103,7 +3103,7 @@ WmProtocolCmd( if (strcmp(Tcl_GetString(objv[3]), "_NET_WM_PING") == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "may not alter handling of that protocol", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "WM", "PROTOCOL", "RESERVED", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "PROTOCOL", "RESERVED", (char *)NULL); return TCL_ERROR; } @@ -3333,21 +3333,21 @@ WmStackorderCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "window \"%s\" isn't a top-level window", winPtr2->pathName)); - Tcl_SetErrorCode(interp, "TK", "WM", "STACK", "TOPLEVEL", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "STACK", "TOPLEVEL", (char *)NULL); return TCL_ERROR; } if (!Tk_IsMapped(winPtr)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "window \"%s\" isn't mapped", winPtr->pathName)); - Tcl_SetErrorCode(interp, "TK", "WM", "STACK", "MAPPED", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "STACK", "MAPPED", (char *)NULL); return TCL_ERROR; } if (!Tk_IsMapped(winPtr2)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "window \"%s\" isn't mapped", winPtr2->pathName)); - Tcl_SetErrorCode(interp, "TK", "WM", "STACK", "MAPPED", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "STACK", "MAPPED", (char *)NULL); return TCL_ERROR; } @@ -3360,7 +3360,7 @@ WmStackorderCmd( if (windows == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "TkWmStackorderToplevel failed", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "WM", "COMMUNICATION", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "COMMUNICATION", (char *)NULL); return TCL_ERROR; } @@ -3431,7 +3431,7 @@ WmStateCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't change state of %s: it is an icon for %s", Tcl_GetString(objv[2]), Tk_PathName(wmPtr->iconFor))); - Tcl_SetErrorCode(interp, "TK", "WM", "STATE", "ICON", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "STATE", "ICON", (char *)NULL); return TCL_ERROR; } @@ -3464,7 +3464,7 @@ WmStateCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "couldn't send iconify message to window manager", -1)); - Tcl_SetErrorCode(interp, "TK", "WM", "COMMUNICATION", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "COMMUNICATION", (char *)NULL); return TCL_ERROR; } } else { /* OPT_WITHDRAWN */ @@ -3473,7 +3473,7 @@ WmStateCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "couldn't send withdraw message to window manager", -1)); - Tcl_SetErrorCode(interp, "TK", "WM", "COMMUNICATION", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "COMMUNICATION", (char *)NULL); return TCL_ERROR; } } @@ -3627,7 +3627,7 @@ WmTransientCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't make \"%s\" a transient: it is an icon for %s", Tcl_GetString(objv[2]), Tk_PathName(wmPtr->iconFor))); - Tcl_SetErrorCode(interp, "TK", "WM", "TRANSIENT", "ICON", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "TRANSIENT", "ICON", (char *)NULL); return TCL_ERROR; } @@ -3640,7 +3640,7 @@ WmTransientCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't make \"%s\" a container: it is an icon for %s", Tcl_GetString(objv[3]), Tk_PathName(wmPtr2->iconFor))); - Tcl_SetErrorCode(interp, "TK", "WM", "TRANSIENT", "ICON", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "TRANSIENT", "ICON", (char *)NULL); return TCL_ERROR; } @@ -3650,7 +3650,7 @@ WmTransientCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't set \"%s\" as container: would cause management loop", Tk_PathName(containerPtr))); - Tcl_SetErrorCode(interp, "TK", "WM", "TRANSIENT", "SELF", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "TRANSIENT", "SELF", (char *)NULL); return TCL_ERROR; } } @@ -3681,7 +3681,7 @@ WmTransientCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "couldn't send withdraw message to window manager", -1)); - Tcl_SetErrorCode(interp, "TK", "WM", "COMMUNICATION", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "COMMUNICATION", (char *)NULL); return TCL_ERROR; } } else { @@ -3733,14 +3733,14 @@ WmWithdrawCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't withdraw %s: it is an icon for %s", Tcl_GetString(objv[2]), Tk_PathName(wmPtr->iconFor))); - Tcl_SetErrorCode(interp, "TK", "WM", "WITHDRAW", "ICON", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "WITHDRAW", "ICON", (char *)NULL); return TCL_ERROR; } wmPtr->flags |= WM_WITHDRAWN; if (TkpWmSetState(winPtr, WithdrawnState) == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "couldn't send withdraw message to window manager", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "WM", "COMMUNICATION", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "COMMUNICATION", (char *)NULL); return TCL_ERROR; } return TCL_OK; @@ -5721,7 +5721,7 @@ ParseGeometry( error: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad geometry specifier \"%s\"", string)); - Tcl_SetErrorCode(interp, "TK", "VALUE", "GEOMETRY", NULL); + Tcl_SetErrorCode(interp, "TK", "VALUE", "GEOMETRY", (char *)NULL); return TCL_ERROR; } diff --git a/win/Makefile.in b/win/Makefile.in index c477e0d..5abf481 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -406,7 +406,7 @@ TK_OBJS = \ TTK_OBJS = \ ttkWinMonitor.$(OBJEXT) \ ttkWinTheme.$(OBJEXT) \ - ttkWinXPTheme.$(OBJEXT) \ + ttkWinVistaTheme.$(OBJEXT) \ ttkBlink.$(OBJEXT) \ ttkButton.$(OBJEXT) \ ttkCache.$(OBJEXT) \ @@ -432,6 +432,7 @@ TTK_OBJS = \ ttkState.$(OBJEXT) \ ttkTagSet.$(OBJEXT) \ ttkTheme.$(OBJEXT) \ + ttkToggleswitch.$(OBJEXT) \ ttkTrace.$(OBJEXT) \ ttkTrack.$(OBJEXT) \ ttkTreeview.$(OBJEXT) \ @@ -534,7 +535,7 @@ install-binaries: binaries echo "if {![package vsatisfies [package provide Tcl] 9.0]} return";\ echo "if {(\$$::tcl_platform(platform) eq \"unix\") && ([info exists ::env(DISPLAY)]";\ echo " || ([info exists ::argv] && (\"-display\" in \$$::argv)))} {";\ - echo " package ifneeded tk $(VERSION)$(PATCH_LEVEL) [list load [file normalize [file join \$$dir .. .. bin libtcl9tk$(VERSION).dll]]]";\ + echo " package ifneeded tk $(VERSION)$(PATCH_LEVEL) [list load [file normalize [file join \$$dir .. .. bin cygtcl9tk$(VERSION).dll]]]";\ echo "} else {";\ echo " package ifneeded tk $(VERSION)$(PATCH_LEVEL) [list load [file normalize [file join \$$dir .. .. bin $(TK_DLL_FILE)]]]";\ echo "}";\ @@ -547,6 +548,9 @@ install-binaries: binaries $(COPY) $$i "$(LIB_INSTALL_DIR)"; \ fi; \ done + @echo "Installing pkg-config file to $(LIB_INSTALL_DIR)/pkgconfig/" + @$(MKDIR) "$(LIB_INSTALL_DIR)/pkgconfig" + @$(INSTALL_DATA) tk.pc "$(LIB_INSTALL_DIR)/pkgconfig/tk.pc" install-libraries: libraries @for i in "$$($(CYGPATH) $(prefix)/lib)" \ @@ -636,6 +640,27 @@ install-demos: done; install-doc: doc + @for i in "$(MAN_INSTALL_DIR)" "$(MAN1_INSTALL_DIR)" "$(MAN3_INSTALL_DIR)" "$(MANN_INSTALL_DIR)" ; \ + do \ + if [ ! -d "$$i" ] ; then \ + echo "Making directory $$i"; \ + mkdir -p "$$i"; \ + chmod 755 "$$i"; \ + else true; \ + fi; \ + done; + @echo "Installing and cross-linking top-level (.1) docs"; + @for i in $(ROOT_DIR)/doc/*.1; do \ + $(SHELL) $(UNIX_DIR)/installManPage $(MAN_FLAGS) $$i "$(MAN1_INSTALL_DIR)"; \ + done + @echo "Installing and cross-linking C API (.3) docs"; + @for i in $(ROOT_DIR)/doc/*.3; do \ + $(SHELL) $(UNIX_DIR)/installManPage $(MAN_FLAGS) $$i "$(MAN3_INSTALL_DIR)"; \ + done + @echo "Installing and cross-linking command (.n) docs"; + @for i in $(ROOT_DIR)/doc/*.n; do \ + $(SHELL) $(UNIX_DIR)/installManPage $(MAN_FLAGS) $$i "$(MANN_INSTALL_DIR)"; \ + done # Optional target to install private headers install-private-headers: libraries diff --git a/win/configure b/win/configure index 21e4e37..fa216fd 100755 --- a/win/configure +++ b/win/configure @@ -641,6 +641,8 @@ ac_includes_default="\ ac_header_c_list= ac_subst_vars='LTLIBOBJS LIBOBJS +XFT_LIBS +XLIBSW RES RC_DEFINES RC_DEFINE @@ -2408,7 +2410,7 @@ SHELL=/bin/sh TK_VERSION=9.1 TK_MAJOR_VERSION=9 TK_MINOR_VERSION=1 -TK_PATCH_LEVEL="a0" +TK_PATCH_LEVEL="a1" VER=$TK_MAJOR_VERSION$TK_MINOR_VERSION #------------------------------------------------------------------------ @@ -4363,7 +4365,7 @@ printf "%s\n" "$ac_cv_win32" >&6; } if test "$ac_cv_win32" != "yes"; then as_fn_error $? "${CC} cannot produce win32 executables." "$LINENO" 5 fi - if test "$do64bit" != "arm64"; then + if test "$do64bit" != "arm64" -a "$do64bit" != "aarch64"; then extra_cflags="$extra_cflags -DHAVE_CPUID=1" fi @@ -4453,8 +4455,6 @@ printf "%s\n" "$ac_cv_municode" >&6; } CFLAGS=$hold_cflags if test "$ac_cv_municode" = "yes" ; then extra_ldflags="$extra_ldflags -municode" - else - extra_cflags="$extra_cflags -DTCL_BROKEN_MAINARGS" fi hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -fno-lto" { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for working -fno-lto" >&5 @@ -4493,6 +4493,44 @@ printf "%s\n" "$ac_cv_nolto" >&6; } else CFLAGS_NOLTO="" fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if the linker understands --disable-high-entropy-va" >&5 +printf %s "checking if the linker understands --disable-high-entropy-va... " >&6; } +if test ${tcl_cv_ld_high_entropy+y} +then : + printf %s "(cached) " >&6 +else case e in #( + e) + hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Wl,--disable-high-entropy-va" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main (void) +{ + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO" +then : + tcl_cv_ld_high_entropy=yes +else case e in #( + e) tcl_cv_ld_high_entropy=no ;; +esac +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext + CFLAGS=$hold_cflags ;; +esac +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_ld_high_entropy" >&5 +printf "%s\n" "$tcl_cv_ld_high_entropy" >&6; } + if test $tcl_cv_ld_high_entropy = yes; then + extra_ldflags="$extra_ldflags -Wl,--disable-high-entropy-va" + fi + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if the compiler understands -finput-charset" >&5 printf %s "checking if the compiler understands -finput-charset... " >&6; } if test ${tcl_cv_cc_input_charset+y} @@ -4548,14 +4586,15 @@ main (void) return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO" +if ac_fn_c_try_link "$LINENO" then : ac_cv_enable_auto_image_base=yes else case e in #( e) ac_cv_enable_auto_image_base=no ;; esac fi -rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext +rm -f core conftest.err conftest.$ac_objext conftest.beam \ + conftest$ac_exeext conftest.$ac_ext ;; esac fi @@ -4573,7 +4612,7 @@ printf %s "checking compiler flags... " >&6; } SHLIB_LD_LIBS='${LIBS}' LIBS="-lnetapi32 -lkernel32 -luser32 -ladvapi32 -luserenv -lws2_32" # mingw needs to link ole32 and oleaut32 for [send], but MSVC doesn't - LIBS_GUI="-lgdi32 -lcomdlg32 -limm32 -lcomctl32 -lshell32 -luuid -lole32 -loleaut32 -lwinspool" + LIBS_GUI="-lgdi32 -lcomdlg32 -limm32 -lcomctl32 -lshell32 -luuid -loleacc -lole32 -loleaut32 -lwinspool -luxtheme -luiautomationcore" STLIB_LD='${AR} cr' RC_OUT=-o RC_TYPE= @@ -4728,7 +4767,7 @@ printf "%s\n" "using shared flags" >&6; } EXESUFFIX=".exe" case "x`echo \${VisualStudioVersion}`" in x1[4-9]*) - lflags="${lflags} -nodefaultlib:libucrt.lib" + lflags="${lflags} -nodefaultlib:ucrt.lib" ;; *) ;; @@ -4787,7 +4826,7 @@ printf "%s\n" " Using 64-bit $MACHINE mode" >&6; } LINKBIN="link" fi - LIBS_GUI="gdi32.lib comdlg32.lib imm32.lib comctl32.lib shell32.lib uuid.lib winspool.lib" + LIBS_GUI="gdi32.lib comdlg32.lib imm32.lib comctl32.lib shell32.lib uuid.lib winspool.lib uxtheme.lib oleacc.lib ole32.lib uiautomationcore.lib" SHLIB_LD="${LINKBIN} -dll -incremental:no ${lflags}" SHLIB_LD_LIBS='${LIBS}' @@ -4977,15 +5016,6 @@ printf "%s\n" "#define EXCEPTION_DISPOSITION int" >>confdefs.h fi - ac_fn_c_check_header_compile "$LINENO" "stdbool.h" "ac_cv_header_stdbool_h" "$ac_includes_default" -if test "x$ac_cv_header_stdbool_h" = xyes -then : - -printf "%s\n" "#define HAVE_STDBOOL_H 1" >>confdefs.h - -fi - - # See if the compiler supports casting to a union type. # This is used to stop gcc from printing a compiler # warning when initializing a union member. @@ -5998,6 +6028,10 @@ TK_WIN_VERSION="$TK_VERSION.$TK_RELEASE_LEVEL.`echo $TK_PATCH_LEVEL | tr -d ab.` + +ac_config_files="$ac_config_files tk.pc:../unix/tk.pc.in" + + ac_config_files="$ac_config_files Makefile tkConfig.sh wish.exe.manifest" cat >confcache <<\_ACEOF @@ -6701,6 +6735,7 @@ cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 for ac_config_target in $ac_config_targets do case $ac_config_target in + "tk.pc") CONFIG_FILES="$CONFIG_FILES tk.pc:../unix/tk.pc.in" ;; "Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;; "tkConfig.sh") CONFIG_FILES="$CONFIG_FILES tkConfig.sh" ;; "wish.exe.manifest") CONFIG_FILES="$CONFIG_FILES wish.exe.manifest" ;; diff --git a/win/configure.ac b/win/configure.ac index 39d3d2b..ee7b309 100644 --- a/win/configure.ac +++ b/win/configure.ac @@ -15,7 +15,7 @@ SHELL=/bin/sh TK_VERSION=9.1 TK_MAJOR_VERSION=9 TK_MINOR_VERSION=1 -TK_PATCH_LEVEL="a0" +TK_PATCH_LEVEL="a1" VER=$TK_MAJOR_VERSION$TK_MINOR_VERSION #------------------------------------------------------------------------ @@ -356,6 +356,11 @@ AC_SUBST(RC_INCLUDE) AC_SUBST(RC_DEFINE) AC_SUBST(RC_DEFINES) AC_SUBST(RES) +AC_SUBST(XLIBSW) +AC_SUBST(XFT_LIBS) +AC_CONFIG_FILES([ + tk.pc:../unix/tk.pc.in +]) AC_CONFIG_FILES([Makefile tkConfig.sh wish.exe.manifest]) AC_OUTPUT diff --git a/win/makefile.vc b/win/makefile.vc index 28e4535..4663822 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -272,7 +272,7 @@ TKOBJS = \ TTK_OBJS = \
$(TMP_DIR)\ttkWinMonitor.obj \
$(TMP_DIR)\ttkWinTheme.obj \
- $(TMP_DIR)\ttkWinXPTheme.obj \
+ $(TMP_DIR)\ttkWinVistaTheme.obj \
$(TMP_DIR)\ttkBlink.obj \
$(TMP_DIR)\ttkButton.obj \
$(TMP_DIR)\ttkCache.obj \
@@ -298,6 +298,7 @@ TTK_OBJS = \ $(TMP_DIR)\ttkState.obj \
$(TMP_DIR)\ttkTagSet.obj \
$(TMP_DIR)\ttkTheme.obj \
+ $(TMP_DIR)\ttkToggleswitch.obj \
$(TMP_DIR)\ttkTrace.obj \
$(TMP_DIR)\ttkTrack.obj \
$(TMP_DIR)\ttkTreeview.obj \
@@ -732,7 +733,7 @@ install-binaries: if {![package vsatisfies [package provide Tcl] 9.0]} return
if {($$::tcl_platform(platform) eq "unix") && ([info exists ::env(DISPLAY)]
|| ([info exists ::argv] && ("-display" in $$::argv)))} {
- package ifneeded tk $(TK_PATCH_LEVEL) [list load [file normalize [file join $$dir .. .. bin libtcl9tk$(DOTVERSION).dll]]]
+ package ifneeded tk $(TK_PATCH_LEVEL) [list load [file normalize [file join $$dir .. .. bin cygtcl9tk$(DOTVERSION).dll]]]
} else {
package ifneeded tk $(TK_PATCH_LEVEL) [list load [file normalize [file join $$dir .. .. bin $(TKLIBNAME)]]]
}
diff --git a/win/rules.vc b/win/rules.vc index 0b47765..15ae8a0 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -804,10 +804,10 @@ DOTSEPARATED=$(DOTSEPARATED:b=.) # MSVCRT - 1 -> link to dynamic C runtime even when building static Tcl build
# 0 -> link to static C runtime for static Tcl build.
# Does not impact shared Tcl builds (STATIC_BUILD == 0)
-# Default: 1 for Tcl 8.7 and up, 0 otherwise.
+# Default: 1 for Tcl 9.0 and up, 0 otherwise.
# TCL_USE_STATIC_PACKAGES - 1 -> statically link the registry and dde extensions
# in the Tcl and Wish shell. 0 -> keep them as shared libraries. Does
-# not impact shared Tcl builds. Implied by STATIC_BUILD since Tcl 8.7.
+# not impact shared Tcl builds. Implied by STATIC_BUILD since Tcl 9.0.
# USE_THREAD_ALLOC - 1 -> Use a shared global free pool for allocation.
# 0 -> Use the non-thread allocator.
# UNCHECKED - 1 -> when doing a debug build with symbols, use the release
@@ -1042,7 +1042,7 @@ WARNINGS = $(WARNINGS) -Wp64 # different compilers, build configurations etc.,
#
# Naming convention (suffixes):
-# t = full thread support. (Not used for Tcl >= 8.7)
+# t = full thread support. (Not used for Tcl >= 9.0)
# s = static library (as opposed to an import library)
# g = linked to the debug enabled C run-time.
# x = special static build when it links to the dynamic C run-time.
@@ -1173,7 +1173,7 @@ TCLSTUBLIB = $(_TCLDIR)\lib\tclstub.lib !endif
TCLIMPLIB = $(_TCLDIR)\lib\tcl$(TCL_VERSION)$(SUFX:t=).lib
# When building extensions, may be linking against Tcl that does not add
-# "t" suffix (e.g. 8.5 or 8.7). If lib not found check for that possibility.
+# "t" suffix (e.g. 8.6). If lib not found check for that possibility.
!if !exist("$(TCLIMPLIB)")
TCLIMPLIB = $(_TCLDIR)\lib\tcl$(TCL_VERSION)t$(SUFX:t=).lib
!endif
@@ -1197,7 +1197,7 @@ TCLSTUBLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclstub.lib !endif
TCLIMPLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tcl$(TCL_VERSION)$(SUFX:t=).lib
# When building extensions, may be linking against Tcl that does not add
-# "t" suffix (e.g. 8.5 or 8.7). If lib not found check for that possibility.
+# "t" suffix (e.g. 8.6). If lib not found check for that possibility.
!if !exist("$(TCLIMPLIB)")
TCLIMPLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tcl$(TCL_VERSION)t$(SUFX:t=).lib
!endif
@@ -1262,7 +1262,7 @@ WISH = $(_TKDIR)\bin\$(WISHNAME) TKSTUBLIB = $(_TKDIR)\lib\$(TKSTUBLIBNAME)
TKIMPLIB = $(_TKDIR)\lib\$(TKIMPLIBNAME)
# When building extensions, may be linking against Tk that does not add
-# "t" suffix (e.g. 8.5 or 8.7). If lib not found check for that possibility.
+# "t" suffix (e.g. 8.6). If lib not found check for that possibility.
!if !exist("$(TKIMPLIB)")
TKIMPLIBNAME = tk$(TK_VERSION)$(SUFX:t=).lib
TKIMPLIB = $(_TKDIR)\lib\$(TKIMPLIBNAME)
@@ -1276,7 +1276,7 @@ WISH = $(_TKDIR)\win\$(BUILDDIRTOP)\$(WISHNAME) TKSTUBLIB = $(_TKDIR)\win\$(BUILDDIRTOP)\$(TKSTUBLIBNAME)
TKIMPLIB = $(_TKDIR)\win\$(BUILDDIRTOP)\$(TKIMPLIBNAME)
# When building extensions, may be linking against Tk that does not add
-# "t" suffix (e.g. 8.5 or 8.7). If lib not found check for that possibility.
+# "t" suffix (e.g. 8.6). If lib not found check for that possibility.
!if !exist("$(TKIMPLIB)")
TKIMPLIBNAME = tk$(TK_VERSION)$(SUFX:t=).lib
TKIMPLIB = $(_TKDIR)\win\$(BUILDDIRTOP)\$(TKIMPLIBNAME)
diff --git a/win/stubs.c b/win/stubs.c index 2cd4d34..12771f1 100644 --- a/win/stubs.c +++ b/win/stubs.c @@ -440,12 +440,3 @@ XVisualIDFromVisual( { return visual->visualid; } - -int -XOffsetRegion( - TCL_UNUSED(Region), - TCL_UNUSED(int), - TCL_UNUSED(int)) -{ - return 0; -} @@ -593,7 +593,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ if test "$ac_cv_win32" != "yes"; then AC_MSG_ERROR([${CC} cannot produce win32 executables.]) fi - if test "$do64bit" != "arm64"; then + if test "$do64bit" != "arm64" -a "$do64bit" != "aarch64"; then extra_cflags="$extra_cflags -DHAVE_CPUID=1" fi @@ -610,8 +610,6 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ CFLAGS=$hold_cflags if test "$ac_cv_municode" = "yes" ; then extra_ldflags="$extra_ldflags -municode" - else - extra_cflags="$extra_cflags -DTCL_BROKEN_MAINARGS" fi hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -fno-lto" AC_CACHE_CHECK(for working -fno-lto, @@ -626,6 +624,16 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ else CFLAGS_NOLTO="" fi + + AC_CACHE_CHECK([if the linker understands --disable-high-entropy-va], + tcl_cv_ld_high_entropy, [ + hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Wl,--disable-high-entropy-va" + AC_LINK_IFELSE([AC_LANG_PROGRAM([[]], [[]])],[tcl_cv_ld_high_entropy=yes],[tcl_cv_ld_high_entropy=no]) + CFLAGS=$hold_cflags]) + if test $tcl_cv_ld_high_entropy = yes; then + extra_ldflags="$extra_ldflags -Wl,--disable-high-entropy-va" + fi + AC_CACHE_CHECK([if the compiler understands -finput-charset], tcl_cv_cc_input_charset, [ hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -finput-charset=UTF-8" @@ -639,7 +647,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Wl,--enable-auto-image-base" AC_CACHE_CHECK(for working --enable-auto-image-base, ac_cv_enable_auto_image_base, - AC_COMPILE_IFELSE([AC_LANG_PROGRAM([])], + AC_LINK_IFELSE([AC_LANG_PROGRAM([])], [ac_cv_enable_auto_image_base=yes], [ac_cv_enable_auto_image_base=no]) ) @@ -654,7 +662,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ SHLIB_LD_LIBS='${LIBS}' LIBS="-lnetapi32 -lkernel32 -luser32 -ladvapi32 -luserenv -lws2_32" # mingw needs to link ole32 and oleaut32 for [send], but MSVC doesn't - LIBS_GUI="-lgdi32 -lcomdlg32 -limm32 -lcomctl32 -lshell32 -luuid -lole32 -loleaut32 -lwinspool" + LIBS_GUI="-lgdi32 -lcomdlg32 -limm32 -lcomctl32 -lshell32 -luuid -loleacc -lole32 -loleaut32 -lwinspool -luxtheme -luiautomationcore" STLIB_LD='${AR} cr' RC_OUT=-o RC_TYPE= @@ -785,7 +793,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ EXESUFFIX=".exe" case "x`echo \${VisualStudioVersion}`" in x1[[4-9]]*) - lflags="${lflags} -nodefaultlib:libucrt.lib" + lflags="${lflags} -nodefaultlib:ucrt.lib" ;; *) ;; @@ -843,7 +851,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ LINKBIN="link" fi - LIBS_GUI="gdi32.lib comdlg32.lib imm32.lib comctl32.lib shell32.lib uuid.lib winspool.lib" + LIBS_GUI="gdi32.lib comdlg32.lib imm32.lib comctl32.lib shell32.lib uuid.lib winspool.lib uxtheme.lib oleacc.lib ole32.lib uiautomationcore.lib" SHLIB_LD="${LINKBIN} -dll -incremental:no ${lflags}" SHLIB_LD_LIBS='${LIBS}' @@ -938,8 +946,6 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ [Defined when cygwin/mingw does not support EXCEPTION DISPOSITION]) fi - AC_CHECK_HEADER(stdbool.h, [AC_DEFINE(HAVE_STDBOOL_H, 1, [Do we have <stdbool.h>?])],) - # See if the compiler supports casting to a union type. # This is used to stop gcc from printing a compiler # warning when initializing a union member. diff --git a/win/tkWin.h b/win/tkWin.h index 460d0c1..69b58c6 100644 --- a/win/tkWin.h +++ b/win/tkWin.h @@ -80,6 +80,6 @@ *-------------------------------------------------------------- */ -#include "tkPlatDecls.h" +#include "tkPlatDecls.h" /* IWYU pragma: export */ #endif /* _TKWIN */ diff --git a/win/tkWin32Dll.c b/win/tkWin32Dll.c index 1e4bf1b..fa8839c 100644 --- a/win/tkWin32Dll.c +++ b/win/tkWin32Dll.c @@ -12,7 +12,7 @@ #include "tkWinInt.h" #ifndef STATIC_BUILD -#ifdef HAVE_NO_SEH +#if defined(HAVE_NO_SEH) && !defined(__aarch64__) /* * Unlike Borland and Microsoft, we don't register exception handlers by diff --git a/win/tkWin3d.c b/win/tkWin3d.c index c5dfeb4..54bba58 100644 --- a/win/tkWin3d.c +++ b/win/tkWin3d.c @@ -336,7 +336,7 @@ TkpGetShadows( { XColor lightColor, darkColor; int tmp1, tmp2; - int r, g, b; + unsigned short r, g, b; XGCValues gcValues; if (borderPtr->lightGC != NULL) { @@ -404,18 +404,18 @@ TkpGetShadows( * Compute the dark shadow color */ - r = (int) borderPtr->bgColorPtr->red; - g = (int) borderPtr->bgColorPtr->green; - b = (int) borderPtr->bgColorPtr->blue; + r = borderPtr->bgColorPtr->red; + g = borderPtr->bgColorPtr->green; + b = borderPtr->bgColorPtr->blue; if (r*0.5*r + g*1.0*g + b*0.28*b < MAX_INTENSITY*0.05*MAX_INTENSITY) { - darkColor.red = (MAX_INTENSITY + 3*r)/4; - darkColor.green = (MAX_INTENSITY + 3*g)/4; - darkColor.blue = (MAX_INTENSITY + 3*b)/4; + darkColor.red = (unsigned short)((MAX_INTENSITY + 3*r)/4); + darkColor.green = (unsigned short)((MAX_INTENSITY + 3*g)/4); + darkColor.blue = (unsigned short)((MAX_INTENSITY + 3*b)/4); } else { - darkColor.red = (60 * r)/100; - darkColor.green = (60 * g)/100; - darkColor.blue = (60 * b)/100; + darkColor.red = (unsigned short)((60 * r)/100); + darkColor.green = (unsigned short)((60 * g)/100); + darkColor.blue = (unsigned short)((60 * b)/100); } /* @@ -431,28 +431,28 @@ TkpGetShadows( */ if (g > MAX_INTENSITY*0.95) { - lightColor.red = (90 * r)/100; - lightColor.green = (90 * g)/100; - lightColor.blue = (90 * b)/100; + lightColor.red = (unsigned short)((90 * r)/100); + lightColor.green = (unsigned short)((90 * g)/100); + lightColor.blue = (unsigned short)((90 * b)/100); } else { tmp1 = (14 * r)/10; if (tmp1 > MAX_INTENSITY) { tmp1 = MAX_INTENSITY; } tmp2 = (MAX_INTENSITY + r)/2; - lightColor.red = (tmp1 > tmp2) ? tmp1 : tmp2; + lightColor.red = (unsigned short)((tmp1 > tmp2) ? tmp1 : tmp2); tmp1 = (14 * g)/10; if (tmp1 > MAX_INTENSITY) { tmp1 = MAX_INTENSITY; } tmp2 = (MAX_INTENSITY + g)/2; - lightColor.green = (tmp1 > tmp2) ? tmp1 : tmp2; + lightColor.green = (unsigned short)((tmp1 > tmp2) ? tmp1 : tmp2); tmp1 = (14 * b)/10; if (tmp1 > MAX_INTENSITY) { tmp1 = MAX_INTENSITY; } tmp2 = (MAX_INTENSITY + b)/2; - lightColor.blue = (tmp1 > tmp2) ? tmp1 : tmp2; + lightColor.blue = (unsigned short)((tmp1 > tmp2) ? tmp1 : tmp2); } /* diff --git a/win/tkWinClipboard.c b/win/tkWinClipboard.c index f51bf8a..4fcff8b 100644 --- a/win/tkWinClipboard.c +++ b/win/tkWinClipboard.c @@ -62,7 +62,7 @@ TkSelGetSelection( if (!OpenClipboard(NULL)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "clipboard cannot be opened, another application grabbed it")); - Tcl_SetErrorCode(interp, "TK", "CLIPBOARD", "BUSY", NULL); + Tcl_SetErrorCode(interp, "TK", "CLIPBOARD", "BUSY", (char *)NULL); return TCL_ERROR; } @@ -204,7 +204,7 @@ TkSelGetSelection( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s selection doesn't exist or form \"%s\" not defined", Tk_GetAtomName(tkwin, selection), Tk_GetAtomName(tkwin, target))); - Tcl_SetErrorCode(interp, "TK", "SELECTION", "EXISTS", NULL); + Tcl_SetErrorCode(interp, "TK", "SELECTION", "EXISTS", (char *)NULL); return TCL_ERROR; } @@ -366,11 +366,13 @@ TkWinClipboardRender( void TkSelUpdateClipboard( TkWindow *winPtr, - TCL_UNUSED(TkClipboardTarget *)) + clipboardOption opt) { - HWND hwnd = TkWinGetHWND(winPtr->window); + if (opt == CLIPBOARD_APPEND || opt == CLIPBOARD_CLEAR) { + HWND hwnd = TkWinGetHWND(winPtr->window); - UpdateClipboard(hwnd); + UpdateClipboard(hwnd); + } } /* diff --git a/win/tkWinColor.c b/win/tkWinColor.c index 9735665..9fb8727 100644 --- a/win/tkWinColor.c +++ b/win/tkWinColor.c @@ -156,7 +156,7 @@ FindSystemColor( TkColor * TkpGetColor( Tk_Window tkwin, /* Window in which color will be used. */ - Tk_Uid name) /* Name of color to allocated (in form + const char *name) /* Name of color to allocated (in form * suitable for passing to XParseColor). */ { WinColor *winColPtr; @@ -494,7 +494,7 @@ XCreateColormap( logPalettePtr = (LOGPALETTE *) logPalBuf; logPalettePtr->palVersion = 0x300; sysPal = (HPALETTE) GetStockObject(DEFAULT_PALETTE); - logPalettePtr->palNumEntries = GetPaletteEntries(sysPal, 0, 256, + logPalettePtr->palNumEntries = (WORD)GetPaletteEntries(sysPal, 0, 256, logPalettePtr->palPalEntry); cmap = (TkWinColormap *)ckalloc(sizeof(TkWinColormap)); diff --git a/win/tkWinCursor.c b/win/tkWinCursor.c index 4281761..6ebeb86 100644 --- a/win/tkWinCursor.c +++ b/win/tkWinCursor.c @@ -133,7 +133,7 @@ TkGetCursorByName( if (Tcl_IsSafe(interp)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot get cursor from a file in a safe interpreter", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "SAFE", "CURSOR_FILE", NULL); + Tcl_SetErrorCode(interp, "TK", "SAFE", "CURSOR_FILE", (char *)NULL); ckfree(argv); ckfree(cursorPtr); return NULL; @@ -169,7 +169,7 @@ TkGetCursorByName( ckfree(argv); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad cursor spec \"%s\"", string)); - Tcl_SetErrorCode(interp, "TK", "VALUE", "CURSOR", NULL); + Tcl_SetErrorCode(interp, "TK", "VALUE", "CURSOR", (char *)NULL); return NULL; } ckfree(argv); diff --git a/win/tkWinDialog.c b/win/tkWinDialog.c index 1a94c33..42bc607 100644 --- a/win/tkWinDialog.c +++ b/win/tkWinDialog.c @@ -193,12 +193,12 @@ static UINT CALLBACK ColorDlgHookProc(HWND hDlg, UINT uMsg, WPARAM wParam, LPARAM lParam); static void CleanupOFNOptions(OFNOpts *optsPtr); static int ParseOFNOptions(void *clientData, - Tcl_Interp *interp, int objc, + Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], enum OFNOper oper, OFNOpts *optsPtr); static int GetFileNameVista(Tcl_Interp *interp, OFNOpts *optsPtr, enum OFNOper oper); static int GetFileName(void *clientData, - Tcl_Interp *interp, int objc, + Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], enum OFNOper oper); static int MakeFilterVista(Tcl_Interp *interp, OFNOpts *optsPtr, DWORD *countPtr, COMDLG_FILTERSPEC **dlgFilterPtrPtr, @@ -314,7 +314,8 @@ Tk_ChooseColorObjCmd( { Tk_Window tkwin = (Tk_Window)clientData, parent; HWND hWnd; - int i, oldMode, winCode, result; + Tcl_Size i; + int oldMode, winCode, result; CHOOSECOLORW chooseColor; static int inited = 0; static COLORREF dwCustColors[16]; @@ -368,7 +369,7 @@ Tk_ChooseColorObjCmd( if (i + 1 == objc) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "value for \"%s\" missing", Tcl_GetString(optionPtr))); - Tcl_SetErrorCode(interp, "TK", "COLORDIALOG", "VALUE", NULL); + Tcl_SetErrorCode(interp, "TK", "COLORDIALOG", "VALUE", (char *)NULL); return TCL_ERROR; } @@ -591,12 +592,12 @@ static int ParseOFNOptions( void *clientData, /* Main window associated with interpreter. */ Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[], /* Argument objects. */ enum OFNOper oper, /* 1 for Open, 0 for Save */ OFNOpts *optsPtr) /* Output, uninitialized on entry */ { - int i; + Tcl_Size i; Tcl_DString ds; enum options { FILE_DEFAULT, FILE_TYPES, FILE_INITDIR, FILE_INITFILE, FILE_PARENT, @@ -662,7 +663,7 @@ ParseOFNOptions( } else if (i + 1 == objc) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "value for \"%s\" missing", options[index].name)); - Tcl_SetErrorCode(interp, "TK", "FILEDIALOG", "VALUE", NULL); + Tcl_SetErrorCode(interp, "TK", "FILEDIALOG", "VALUE", (char *)NULL); goto error_return; } @@ -1054,7 +1055,7 @@ static int GetFileName( void *clientData, /* Main window associated with interpreter. */ Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[], /* Argument objects. */ enum OFNOper oper) /* 1 to call GetOpenFileName(), 0 to call * GetSaveFileName(). */ @@ -1333,8 +1334,8 @@ Tk_MessageBoxObjCmd( Tk_Window tkwin = (Tk_Window)clientData, parent; HWND hWnd; Tcl_Obj *messageObj, *titleObj, *detailObj, *tmpObj; - int defaultBtn, icon, type; - int i, oldMode, winCode; + int defaultBtn, icon, type, oldMode, winCode; + Tcl_Size i; UINT flags; static const char *const optionStrings[] = { "-default", "-detail", "-icon", "-message", @@ -1372,7 +1373,7 @@ Tk_MessageBoxObjCmd( if (i + 1 == objc) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "value for \"%s\" missing", Tcl_GetString(optionPtr))); - Tcl_SetErrorCode(interp, "TK", "MSGBOX", "VALUE", NULL); + Tcl_SetErrorCode(interp, "TK", "MSGBOX", "VALUE", (char *)NULL); return TCL_ERROR; } @@ -1444,7 +1445,7 @@ Tk_MessageBoxObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid default button \"%s\"", TkFindStateString(buttonMap, defaultBtn))); - Tcl_SetErrorCode(interp, "TK", "MSGBOX", "DEFAULT", NULL); + Tcl_SetErrorCode(interp, "TK", "MSGBOX", "DEFAULT", (char *)NULL); return TCL_ERROR; } break; @@ -1763,15 +1764,15 @@ HookProc( * any of the options (which may be NULL in the structure) */ -enum FontchooserOption { +typedef enum { FontchooserCmd, FontchooserFont, FontchooserParent, FontchooserTitle, FontchooserVisible -}; +} FontchooserOption; static Tcl_Obj * FontchooserCget( HookData *hdPtr, - int optionIndex) + FontchooserOption optionIndex) { Tcl_Obj *resObj = NULL; @@ -1857,7 +1858,7 @@ FontchooserConfigureCmd( for (i = 0; r == TCL_OK && optionStrings[i] != NULL; ++i) { keyObj = Tcl_NewStringObj(optionStrings[i], TCL_INDEX_NONE); - valueObj = FontchooserCget(hdPtr, i); + valueObj = FontchooserCget(hdPtr, (FontchooserOption)i); r = Tcl_DictObjPut(interp, dictObj, keyObj, valueObj); } if (r == TCL_OK) { @@ -1884,7 +1885,7 @@ FontchooserConfigureCmd( if (i + 1 == objc) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "value for \"%s\" missing", Tcl_GetString(objv[i]))); - Tcl_SetErrorCode(interp, "TK", "FONTDIALOG", "VALUE", NULL); + Tcl_SetErrorCode(interp, "TK", "FONTDIALOG", "VALUE", (char *)NULL); return TCL_ERROR; } switch (optionIndex) { @@ -1893,7 +1894,7 @@ FontchooserConfigureCmd( "\"-visible\": use the show or hide command"; Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "FONTDIALOG", "READONLY", NULL); + Tcl_SetErrorCode(interp, "TK", "FONTDIALOG", "READONLY", (char *)NULL); return TCL_ERROR; } case FontchooserParent: { diff --git a/win/tkWinDraw.c b/win/tkWinDraw.c index a7ab9c0..333820a 100644 --- a/win/tkWinDraw.c +++ b/win/tkWinDraw.c @@ -29,7 +29,7 @@ const int tkpWinRopModes[] = { R2_MASKPENNOT, /* GXandReverse */ R2_COPYPEN, /* GXcopy */ R2_MASKNOTPEN, /* GXandInverted */ - R2_NOT, /* GXnoop */ + R2_NOP, /* GXnoop */ R2_XORPEN, /* GXxor */ R2_MERGEPEN, /* GXor */ R2_NOTMERGEPEN, /* GXnor */ diff --git a/win/tkWinEmbed.c b/win/tkWinEmbed.c index de4eaba..0d1868b 100644 --- a/win/tkWinEmbed.c +++ b/win/tkWinEmbed.c @@ -164,7 +164,7 @@ void Tk_MapEmbeddedWindow( { if(!(winPtr->flags & TK_ALREADY_DEAD)) { HWND hwnd = (HWND)winPtr->privatePtr; - int state = SendMessageW(hwnd, TK_STATE, -1, (WPARAM)-1) - 1; + int state = (int)SendMessageW(hwnd, TK_STATE, -1, (WPARAM)-1) - 1; if (state < 0 || state > 3) { state = NormalState; @@ -238,7 +238,7 @@ Tk_UseWindow( * tkwin; must be an integer value. */ { TkWindow *winPtr = (TkWindow *) tkwin; - int id; + Tcl_Size id; HWND hwnd; /* ThreadSpecificData *tsdPtr = (ThreadSpecificData *) @@ -249,7 +249,7 @@ Tk_UseWindow( if (winPtr->window != None) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "can't modify container after widget is created", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "EMBED", "POST_CREATE", NULL); + Tcl_SetErrorCode(interp, "TK", "EMBED", "POST_CREATE", (char *)NULL); return TCL_ERROR; } */ @@ -282,7 +282,7 @@ Tk_UseWindow( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "window \"%s\" does not exist", string)); - Tcl_SetErrorCode(interp, "TK", "EMBED", "EXIST", NULL); + Tcl_SetErrorCode(interp, "TK", "EMBED", "EXIST", (char *)NULL); } return TCL_ERROR; } @@ -292,13 +292,13 @@ Tk_UseWindow( if (!SendMessageW(hwnd, TK_INFO, TK_CONTAINER_ISAVAILABLE, 0)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "The container is already in use", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "EMBED", "IN_USE", NULL); + Tcl_SetErrorCode(interp, "TK", "EMBED", "IN_USE", (char *)NULL); return TCL_ERROR; } } else if (id == -PTR2INT(hwnd)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "the window to use is not a Tk container", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "EMBED", "CONTAINER", NULL); + Tcl_SetErrorCode(interp, "TK", "EMBED", "CONTAINER", (char *)NULL); return TCL_ERROR; } else { /* @@ -314,7 +314,7 @@ Tk_UseWindow( MB_OKCANCEL | MB_ICONWARNING)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "Operation has been canceled", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "EMBED", "CANCEL", NULL); + Tcl_SetErrorCode(interp, "TK", "EMBED", "CANCEL", (char *)NULL); return TCL_ERROR; } } @@ -426,7 +426,7 @@ TkWinEmbeddedEventProc( WPARAM wParam, LPARAM lParam) { - int result = 1; + Tcl_Size result = 1; Container *containerPtr; ThreadSpecificData *tsdPtr = (ThreadSpecificData *) Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); @@ -460,8 +460,8 @@ TkWinEmbeddedEventProc( * * TK_CONTAINER_VERIFY - request the container to verify its * identification - * result = (long)hwnd if this window is a container - * -(long)hwnd otherwise + * result = (Tcl_Size)hwnd if this window is a container + * -(Tcl_Size)hwnd otherwise * * lParam - N/A */ @@ -550,7 +550,7 @@ TkWinEmbeddedEventProc( * others - the message is processed. */ - EmbedGeometryRequest(containerPtr, (int)wParam, lParam); + EmbedGeometryRequest(containerPtr, (int)wParam, (int)lParam); break; case TK_RAISEWINDOW: @@ -687,7 +687,7 @@ TkWinEmbeddedEventProc( */ result = TkpWinToplevelMove(containerPtr->parentPtr, - wParam, lParam); + (int)wParam, (int)lParam); break; case TK_OVERRIDEREDIRECT: @@ -706,7 +706,7 @@ TkWinEmbeddedEventProc( * toplevel. Otherwise 0. */ if (topwinPtr) { - result = 1 + TkpWinToplevelOverrideRedirect(topwinPtr, wParam); + result = 1 + TkpWinToplevelOverrideRedirect(topwinPtr, (int)wParam); } else { result = 0; } @@ -751,7 +751,7 @@ TkWinEmbeddedEventProc( if (topwinPtr) { if (wParam <= 3) { - TkpWmSetState(topwinPtr, wParam); + TkpWmSetState(topwinPtr, (int)wParam); } result = 1+TkpWmGetState(topwinPtr); } else { diff --git a/win/tkWinFont.c b/win/tkWinFont.c index 04b1105..b1dc52e 100644 --- a/win/tkWinFont.c +++ b/win/tkWinFont.c @@ -853,7 +853,7 @@ Tk_MeasureChars( p - start, &runString); size.cx = 0; familyPtr->getTextExtentPoint32Proc(hdc, wstr, - Tcl_DStringLength(&runString) >> familyPtr->isWideFont, + (int)(Tcl_DStringLength(&runString) >> familyPtr->isWideFont), &size); Tcl_DStringFree(&runString); if (maxLength >= 0 && (curX+size.cx) > maxLength) { @@ -880,7 +880,7 @@ Tk_MeasureChars( p - start, &runString); size.cx = 0; familyPtr->getTextExtentPoint32Proc(hdc, wstr, - Tcl_DStringLength(&runString) >> familyPtr->isWideFont, + (int)(Tcl_DStringLength(&runString) >> familyPtr->isWideFont), &size); Tcl_DStringFree(&runString); if (maxLength >= 0 && (curX+size.cx) > maxLength) { @@ -914,7 +914,7 @@ Tk_MeasureChars( size.cx = 0; familyPtr->getTextExtentPoint32Proc(hdc, (WCHAR *) Tcl_DStringValue(&runString), - Tcl_DStringLength(&runString) >> familyPtr->isWideFont, + (int)(Tcl_DStringLength(&runString) >> familyPtr->isWideFont), &size); if ((curX+size.cx) > maxLength) { break; @@ -1128,7 +1128,7 @@ Tk_DrawChars( * Compute the bounding box and create a compatible bitmap. */ - GetTextExtentPointA(dcMem, source, numBytes, &size); + GetTextExtentPointA(dcMem, source, (int)numBytes, &size); GetTextMetricsW(dcMem, &tm); size.cx -= tm.tmOverhang; bitmap = CreateCompatibleBitmap(dc, size.cx, size.cy); @@ -1143,11 +1143,11 @@ Tk_DrawChars( */ PatBlt(dcMem, 0, 0, size.cx, size.cy, BLACKNESS); - MultiFontTextOut(dc, fontPtr, source, numBytes, x, y, 0.0); + MultiFontTextOut(dc, fontPtr, source, (int)numBytes, x, y, 0.0); BitBlt(dc, x, y - tm.tmAscent, size.cx, size.cy, dcMem, 0, 0, 0xEA02E9); PatBlt(dcMem, 0, 0, size.cx, size.cy, WHITENESS); - MultiFontTextOut(dc, fontPtr, source, numBytes, x, y, 0.0); + MultiFontTextOut(dc, fontPtr, source, (int)numBytes, x, y, 0.0); BitBlt(dc, x, y - tm.tmAscent, size.cx, size.cy, dcMem, 0, 0, 0x8A0E06); @@ -1164,7 +1164,7 @@ Tk_DrawChars( SetTextAlign(dc, TA_LEFT | TA_BASELINE); SetTextColor(dc, gc->foreground); SetBkMode(dc, TRANSPARENT); - MultiFontTextOut(dc, fontPtr, source, numBytes, x, y, 0.0); + MultiFontTextOut(dc, fontPtr, source, (int)numBytes, x, y, 0.0); } else { HBITMAP oldBitmap, bitmap; HDC dcMem; @@ -1182,13 +1182,13 @@ Tk_DrawChars( * Compute the bounding box and create a compatible bitmap. */ - GetTextExtentPointA(dcMem, source, numBytes, &size); + GetTextExtentPointA(dcMem, source, (int)numBytes, &size); GetTextMetricsW(dcMem, &tm); size.cx -= tm.tmOverhang; bitmap = CreateCompatibleBitmap(dc, size.cx, size.cy); oldBitmap = (HBITMAP)SelectObject(dcMem, bitmap); - MultiFontTextOut(dcMem, fontPtr, source, numBytes, 0, tm.tmAscent, + MultiFontTextOut(dcMem, fontPtr, source, (int)numBytes, 0, tm.tmAscent, 0.0); BitBlt(dc, x, y - tm.tmAscent, size.cx, size.cy, dcMem, 0, 0, (DWORD) tkpWinBltModes[gc->function]); @@ -1276,7 +1276,7 @@ TkDrawAngledChars( * Compute the bounding box and create a compatible bitmap. */ - GetTextExtentPointA(dcMem, source, numBytes, &size); + GetTextExtentPointA(dcMem, source, (int)numBytes, &size); GetTextMetricsW(dcMem, &tm); size.cx -= tm.tmOverhang; bitmap = CreateCompatibleBitmap(dc, size.cx, size.cy); @@ -1291,11 +1291,11 @@ TkDrawAngledChars( */ PatBlt(dcMem, 0, 0, size.cx, size.cy, BLACKNESS); - MultiFontTextOut(dc, fontPtr, source, numBytes, x, y, angle); + MultiFontTextOut(dc, fontPtr, source, (int)numBytes, x, y, angle); BitBlt(dc, (int)x, (int)y - tm.tmAscent, size.cx, size.cy, dcMem, 0, 0, 0xEA02E9); PatBlt(dcMem, 0, 0, size.cx, size.cy, WHITENESS); - MultiFontTextOut(dc, fontPtr, source, numBytes, x, y, angle); + MultiFontTextOut(dc, fontPtr, source, (int)numBytes, x, y, angle); BitBlt(dc, (int)x, (int)y - tm.tmAscent, size.cx, size.cy, dcMem, 0, 0, 0x8A0E06); @@ -1312,7 +1312,7 @@ TkDrawAngledChars( SetTextAlign(dc, TA_LEFT | TA_BASELINE); SetTextColor(dc, gc->foreground); SetBkMode(dc, TRANSPARENT); - MultiFontTextOut(dc, fontPtr, source, numBytes, x, y, angle); + MultiFontTextOut(dc, fontPtr, source, (int)numBytes, x, y, angle); } else { HBITMAP oldBitmap, bitmap; HDC dcMem; @@ -1330,13 +1330,13 @@ TkDrawAngledChars( * Compute the bounding box and create a compatible bitmap. */ - GetTextExtentPointA(dcMem, source, numBytes, &size); + GetTextExtentPointA(dcMem, source, (int)numBytes, &size); GetTextMetricsW(dcMem, &tm); size.cx -= tm.tmOverhang; bitmap = CreateCompatibleBitmap(dc, size.cx, size.cy); oldBitmap = (HBITMAP)SelectObject(dcMem, bitmap); - MultiFontTextOut(dcMem, fontPtr, source, numBytes, 0, tm.tmAscent, + MultiFontTextOut(dcMem, fontPtr, source, (int)numBytes, 0, tm.tmAscent, angle); BitBlt(dc, (int)x, (int)y - tm.tmAscent, size.cx, size.cy, dcMem, 0, 0, (DWORD) tkpWinBltModes[gc->function]); @@ -1493,10 +1493,10 @@ MultiFontTextOut( familyPtr = lastSubFontPtr->familyPtr; WCHAR *wstr = (WCHAR *)Tcl_UtfToExternalDString(familyPtr->encoding, source, p - source, &runString); - familyPtr->textOutProc(hdc, (int)(x-(double)tm.tmOverhang/2.0), y, - wstr, Tcl_DStringLength(&runString) >> familyPtr->isWideFont); + familyPtr->textOutProc(hdc, (int)(x-(double)tm.tmOverhang/2.0), (int)y, + wstr, (int)(Tcl_DStringLength(&runString) >> familyPtr->isWideFont)); familyPtr->getTextExtentPoint32Proc(hdc, - wstr, Tcl_DStringLength(&runString) >> familyPtr->isWideFont, + wstr, (int)(Tcl_DStringLength(&runString) >> familyPtr->isWideFont), &size); x += cosA*size.cx; y -= sinA*size.cx; @@ -1513,8 +1513,8 @@ MultiFontTextOut( familyPtr = lastSubFontPtr->familyPtr; WCHAR *wstr = (WCHAR *)Tcl_UtfToExternalDString(familyPtr->encoding, source, p - source, &runString); - familyPtr->textOutProc(hdc, (int)(x-(double)tm.tmOverhang/2.0), y, - wstr, Tcl_DStringLength(&runString) >> familyPtr->isWideFont); + familyPtr->textOutProc(hdc, (int)(x-(double)tm.tmOverhang/2.0), (int)y, + wstr, (int)(Tcl_DStringLength(&runString) >> familyPtr->isWideFont)); Tcl_DStringFree(&runString); } SelectObject(hdc, oldFont); @@ -2500,9 +2500,9 @@ GetScreenFont( lf.lfEscapement = ROUND16(angle * 10); lf.lfOrientation = ROUND16(angle * 10); lf.lfWeight = (faPtr->weight == TK_FW_NORMAL) ? FW_NORMAL : FW_BOLD; - lf.lfItalic = faPtr->slant; - lf.lfUnderline = faPtr->underline; - lf.lfStrikeOut = faPtr->overstrike; + lf.lfItalic = (BYTE)faPtr->slant; + lf.lfUnderline = (BYTE)faPtr->underline; + lf.lfStrikeOut = (BYTE)faPtr->overstrike; lf.lfCharSet = DEFAULT_CHARSET; lf.lfOutPrecision = OUT_TT_PRECIS; lf.lfClipPrecision = CLIP_DEFAULT_PRECIS; @@ -2800,9 +2800,9 @@ LoadFontRanges( endCount = (USHORT *)ckalloc(cbData); offset = encTable.offset + sizeof(subTable.segment); - GetFontData(hdc, cmapKey, (DWORD) offset, endCount, cbData); + GetFontData(hdc, cmapKey, (DWORD) offset, endCount, (DWORD)cbData); offset += cbData + sizeof(USHORT); - GetFontData(hdc, cmapKey, (DWORD) offset, startCount, cbData); + GetFontData(hdc, cmapKey, (DWORD) offset, startCount, (DWORD)cbData); if (swapped) { for (j = 0; j < segCount; j++) { SwapShort(&endCount[j]); diff --git a/win/tkWinGDI.c b/win/tkWinGDI.c index bc4f743..25314d1 100644 --- a/win/tkWinGDI.c +++ b/win/tkWinGDI.c @@ -116,6 +116,7 @@ typedef struct WinprintData { * array. The first element is the subcommand name, and the second a standard * Tcl command handler. */ + static const struct gdi_command { const char *command_string; Tcl_ObjCmdProc2 *command; @@ -163,7 +164,7 @@ static Tcl_Size ParseColor ( if (objc == 0) { Tcl_AppendResult(interp, "option \"", Tcl_GetString(objv[-1]), - "\" needs an additional argument", NULL); + "\" needs an additional argument", (char *)NULL); return -1; } @@ -179,7 +180,7 @@ static Tcl_Size ParseColor ( return 1; } - Tcl_AppendResult(interp, "unknown color name \"", colorname, "\"", NULL); + Tcl_AppendResult(interp, "unknown color name \"", colorname, "\"", (char *)NULL); return -1; } @@ -196,7 +197,7 @@ static Tcl_Size ParseDash ( if (objc == 0) { Tcl_AppendResult(interp, - "option \"-dash\" needs an additional argument", NULL); + "option \"-dash\" needs an additional argument", (char *)NULL); return -1; } @@ -234,7 +235,7 @@ static Tcl_Size ParseAnchor ( if (objc == 0) { Tcl_AppendResult(interp, - "option \"-anchor\" needs an additional argument", NULL); + "option \"-anchor\" needs an additional argument", (char *)NULL); return -1; } @@ -259,7 +260,7 @@ static Tcl_Size ParseFont ( if (objc == 0) { Tcl_AppendResult(interp, - "option \"-font\" needs an additional argument", NULL); + "option \"-font\" needs an additional argument", (char *)NULL); return -1; } @@ -271,7 +272,7 @@ static Tcl_Size ParseFont ( if (Tcl_ListObjGetElements(NULL, objv[0], &fcount, &fobjs) != TCL_OK || (fcount < 2 || fcount > 6)) { Tcl_AppendResult(interp, "bad font description \"", fstring, - "\"", NULL); + "\"", (char *)NULL); return -1; } @@ -281,7 +282,7 @@ static Tcl_Size ParseFont ( if (Tcl_GetIntFromObj(interp, fobjs[1], &size) != TCL_OK) { const char *value = Tcl_GetString(fobjs[1]); Tcl_AppendResult(interp, "bad size \"", value, - "\"; should be an integer", NULL); + "\"; should be an integer", (char *)NULL); return -1; } @@ -300,7 +301,7 @@ static Tcl_Size ParseJoinStyle ( if (objc == 0) { Tcl_AppendResult(interp, - "option \"-joinstyle\" needs an additional argument", NULL); + "option \"-joinstyle\" needs an additional argument", (char *)NULL); return -1; } @@ -350,7 +351,7 @@ static Tcl_Size ParseStyle ( if (objc == 0) { Tcl_AppendResult(interp, - "option \"-style\" needs an additional argument", NULL); + "option \"-style\" needs an additional argument", (char *)NULL); return -1; } @@ -383,7 +384,7 @@ static int GdiArc( { WinprintData *dataPtr = (WinprintData *)clientData; if (dataPtr->printDC == NULL) { - Tcl_AppendResult(interp, "device context not initialized", NULL); + Tcl_AppendResult(interp, "device context not initialized", (char *)NULL); return TCL_ERROR; } @@ -587,7 +588,7 @@ static int GdiPhoto( { WinprintData *dataPtr = (WinprintData *)clientData; if (dataPtr->printDC == NULL) { - Tcl_AppendResult(interp, "device context not initialized", NULL); + Tcl_AppendResult(interp, "device context not initialized", (char *)NULL); return TCL_ERROR; } HDC hDC = dataPtr->printDC; @@ -653,14 +654,14 @@ static int GdiPhoto( } if (! photoname) { /* No photo provided. */ - Tcl_AppendResult(interp, "no photo name provided", NULL); + Tcl_AppendResult(interp, "no photo name provided", (char *)NULL); return TCL_ERROR; } photo_handle = Tk_FindPhoto(interp, photoname); if (! photo_handle) { Tcl_AppendResult(interp, "photo name \"", photoname, - "\" can't be located", NULL); + "\" can't be located", (char *)NULL); return TCL_ERROR; } Tk_PhotoGetImage(photo_handle, &img_block); @@ -677,7 +678,7 @@ static int GdiPhoto( pbuf = (char *)attemptckalloc(sll * ny * sizeof(char)); if (! pbuf) { /* Memory allocation failure. */ Tcl_AppendResult(interp, - "::tk::print::_gdi photo failed--out of memory", NULL); + "::tk::print::_gdi photo failed--out of memory", (char *)NULL); return TCL_ERROR; } @@ -882,7 +883,7 @@ static Tcl_Size ParseArrow ( if (objc == 0) { Tcl_AppendResult(interp, - "option \"-arrow\" needs an additional argument", NULL); + "option \"-arrow\" needs an additional argument", (char *)NULL); return -1; } @@ -915,7 +916,7 @@ static Tcl_Size ParseArrShp( if (objc == 0) { Tcl_AppendResult(interp, - "option \"-arrowshape\" requires an additional argument", NULL); + "option \"-arrowshape\" requires an additional argument", (char *)NULL); return -1; } if (Tcl_ListObjGetElements(interp, objv[0], &count, &shpObjs) != TCL_OK) { @@ -926,7 +927,7 @@ static Tcl_Size ParseArrShp( Tcl_GetDoubleFromObj(NULL, shpObjs[1], &a1) != TCL_OK || Tcl_GetDoubleFromObj(NULL, shpObjs[2], &a2) != TCL_OK) { Tcl_AppendResult(interp, "arrow shape should be a list ", - "with three numbers", NULL); + "with three numbers", (char *)NULL); return -1; } arrowShape[0] = ROUND32(a0); @@ -952,7 +953,7 @@ static Tcl_Size ParseCapStyle ( if (objc == 0) { Tcl_AppendResult(interp, - "option \"-capstyle\" needs an additional argument", NULL); + "option \"-capstyle\" needs an additional argument", (char *)NULL); return -1; } @@ -1000,7 +1001,7 @@ static Tcl_Size ParseSmooth( if (objc == 0) { Tcl_AppendResult(interp, - "option \"-smooth\" requires an additional argument", NULL); + "option \"-smooth\" requires an additional argument", (char *)NULL); return -1; } /* Argument is a boolean value, "bezier" or "raw". */ @@ -1011,7 +1012,7 @@ static Tcl_Size ParseSmooth( if (Tcl_GetIndexFromObjStruct(interp, objv[0], smoothmethods, sizeof(struct SmoothMethod), "smooth method", 0, &index) != TCL_OK) { - Tcl_AppendResult(interp, " or a boolean value", NULL); + Tcl_AppendResult(interp, " or a boolean value", (char *)NULL); return -1; } *(int *)dstPtr = smoothmethods[index].method; @@ -1038,7 +1039,7 @@ static int GdiLine( { WinprintData *dataPtr = (WinprintData *)clientData; if (dataPtr->printDC == NULL) { - Tcl_AppendResult(interp, "device context not initialized", NULL); + Tcl_AppendResult(interp, "device context not initialized", (char *)NULL); return TCL_ERROR; } HDC hDC = dataPtr->printDC; @@ -1078,7 +1079,7 @@ static int GdiLine( } polypoints = (POINT *)attemptckalloc((objc - 2)/2 * sizeof(POINT)); if (polypoints == NULL) { - Tcl_AppendResult(interp, "Out of memory in GdiLine", NULL); + Tcl_AppendResult(interp, "Out of memory in GdiLine", (char *)NULL); return TCL_ERROR; } polypoints[0].x = ROUND32(p1x); @@ -1266,7 +1267,7 @@ static int GdiOval( { WinprintData *dataPtr = (WinprintData *)clientData; if (dataPtr->printDC == NULL) { - Tcl_AppendResult(interp, "device context not initialized", NULL); + Tcl_AppendResult(interp, "device context not initialized", (char *)NULL); return TCL_ERROR; } HDC hDC = dataPtr->printDC; @@ -1375,7 +1376,7 @@ static int GdiPolygon( { WinprintData *dataPtr = (WinprintData *)clientData; if (dataPtr->printDC == NULL) { - Tcl_AppendResult(interp, "device context not initialized", NULL); + Tcl_AppendResult(interp, "device context not initialized", (char *)NULL); return TCL_ERROR; } HDC hDC = dataPtr->printDC; @@ -1411,7 +1412,7 @@ static int GdiPolygon( polypoints = (POINT *)attemptckalloc((objc - 2)/2 * sizeof(POINT)); if (polypoints == NULL) { /* TODO: unreachable */ - Tcl_AppendResult(interp, "Out of memory in GdiPolygon", NULL); + Tcl_AppendResult(interp, "Out of memory in GdiPolygon", (char *)NULL); return TCL_ERROR; } polypoints[0].x = ROUND32(p1x); @@ -1515,7 +1516,7 @@ static int GdiRectangle( { WinprintData *dataPtr = (WinprintData *)clientData; if (dataPtr->printDC == NULL) { - Tcl_AppendResult(interp, "device context not initialized", NULL); + Tcl_AppendResult(interp, "device context not initialized", (char *)NULL); return TCL_ERROR; } HDC hDC = dataPtr->printDC; @@ -1634,7 +1635,7 @@ static int GdiCharWidths( */ WinprintData *dataPtr = (WinprintData *)clientData; if (dataPtr->printDC == NULL) { - Tcl_AppendResult(interp, "device context not initialized", NULL); + Tcl_AppendResult(interp, "device context not initialized", (char *)NULL); return TCL_ERROR; } HDC hDC = dataPtr->printDC; @@ -1675,7 +1676,7 @@ static int GdiCharWidths( /* is an error not providing a font */ if (! fontobj) { - Tcl_AppendResult(interp, "error: font must be specified", NULL); + Tcl_AppendResult(interp, "error: font must be specified", (char *)NULL); return TCL_ERROR; } @@ -1728,7 +1729,7 @@ static int GdiCharWidths( } /* The return value should be the array name(?). */ - Tcl_AppendResult(interp, aryvarname, NULL); + Tcl_AppendResult(interp, aryvarname, (char *)NULL); return TCL_OK; } @@ -1792,7 +1793,7 @@ static Tcl_Size ParseJustify ( if (objc == 0) { Tcl_AppendResult(interp, - "option \"-justify\" needs an additional argument", NULL); + "option \"-justify\" needs an additional argument", (char *)NULL); return -1; } @@ -1812,7 +1813,7 @@ static int GdiText( { WinprintData *dataPtr = (WinprintData *)clientData; if (dataPtr->printDC == NULL) { - Tcl_AppendResult(interp, "device context not initialized", NULL); + Tcl_AppendResult(interp, "device context not initialized", (char *)NULL); return TCL_ERROR; } HDC hDC = dataPtr->printDC; @@ -1880,7 +1881,7 @@ static int GdiText( } /* is an error not providing a font */ if (! fontobj) { - Tcl_AppendResult(interp, "error: font must be specified", NULL); + Tcl_AppendResult(interp, "error: font must be specified", (char *)NULL); return TCL_ERROR; } @@ -2027,7 +2028,7 @@ static int GdiTextPlain( { WinprintData *dataPtr = (WinprintData *)clientData; if (dataPtr->printDC == NULL) { - Tcl_AppendResult(interp, "device context not initialized", NULL); + Tcl_AppendResult(interp, "device context not initialized", (char *)NULL); return TCL_ERROR; } HDC hDC = dataPtr->printDC; @@ -2213,7 +2214,7 @@ static int GdiMap( { WinprintData *dataPtr = (WinprintData *)clientData; if (dataPtr->printDC == NULL) { - Tcl_AppendResult(interp, "device context not initialized", NULL); + Tcl_AppendResult(interp, "device context not initialized", (char *)NULL); return TCL_ERROR; } HDC hDC = dataPtr->printDC; @@ -2227,7 +2228,7 @@ static int GdiMap( SIZE vextent; /* Viewport extent. */ POINT worigin; /* Device origin. */ POINT vorigin; /* Viewport origin. */ - int argno; + Tcl_Size argno; /* Keep track of what parts of the function need to be executed. */ int need_usage = 0; @@ -2239,13 +2240,13 @@ static int GdiMap( /* Required parameter: HDC for printer. */ if (objc < 2) { - Tcl_AppendResult(interp, usage_message, NULL); + Tcl_AppendResult(interp, usage_message, (char *)NULL); return TCL_ERROR; } if ((mapmode = GdiGetHdcInfo(hDC, &worigin, &wextent, &vorigin, &vextent)) == 0) { /* Failed!. */ - Tcl_AppendResult(interp, "Cannot get current HDC info", NULL); + Tcl_AppendResult(interp, "Cannot get current HDC info", (char *)NULL); return TCL_ERROR; } @@ -2337,7 +2338,7 @@ static int GdiMap( } if (need_usage) { - Tcl_AppendResult(interp, usage_message, NULL); + Tcl_AppendResult(interp, usage_message, (char *)NULL); return TCL_ERROR; } @@ -2400,7 +2401,7 @@ static int GdiCopyBits( { WinprintData *dataPtr = (WinprintData *)clientData; if (dataPtr->printDC == NULL) { - Tcl_AppendResult(interp, "device context not initialized", NULL); + Tcl_AppendResult(interp, "device context not initialized", (char *)NULL); return TCL_ERROR; } HDC dst = dataPtr->printDC; @@ -2454,7 +2455,7 @@ static int GdiCopyBits( * purpose. */ if ((workwin = mainWin = Tk_MainWindow(interp)) == 0) { - Tcl_AppendResult(interp, "Can't find main Tk window", NULL); + Tcl_AppendResult(interp, "Can't find main Tk window", (char *)NULL); return TCL_ERROR; } @@ -2463,7 +2464,7 @@ static int GdiCopyBits( */ /* HDC is required. */ if (objc < 2) { - Tcl_AppendResult(interp, usage_message, NULL); + Tcl_AppendResult(interp, usage_message, (char *)NULL); return TCL_ERROR; } @@ -2509,7 +2510,7 @@ static int GdiCopyBits( int count = sscanf(Tcl_GetString(objv[++k]), "%f%f%f%f", &a, &b, &c, &d); if (count < 2) { /* Can't make heads or tails of it.... */ - Tcl_AppendResult(interp, usage_message, NULL); + Tcl_AppendResult(interp, usage_message, (char *)NULL); return TCL_ERROR; } src_x = (int)a; @@ -2524,7 +2525,7 @@ static int GdiCopyBits( count = sscanf(Tcl_GetString(objv[++k]), "%f%f%f%f", &a, &b, &c, &d); if (count < 2) { /* Can't make heads or tails of it.... */ - Tcl_AppendResult(interp, usage_message, NULL); + Tcl_AppendResult(interp, usage_message, (char *)NULL); return TCL_ERROR; } dst_x = (int)a; @@ -2560,7 +2561,7 @@ static int GdiCopyBits( * Check to ensure no incompatible arguments were used. */ if (do_window && do_screen) { - Tcl_AppendResult(interp, usage_message, NULL); + Tcl_AppendResult(interp, usage_message, (char *)NULL); return TCL_ERROR; } @@ -2574,7 +2575,7 @@ static int GdiCopyBits( } if ((wnd = Tk_WindowId(workwin)) == 0) { - Tcl_AppendResult(interp, "Can't get id for Tk window", NULL); + Tcl_AppendResult(interp, "Can't get id for Tk window", (char *)NULL); return TCL_ERROR; } @@ -2582,7 +2583,7 @@ static int GdiCopyBits( if ((hwnd = Tk_GetHWND(wnd)) == 0) { Tcl_AppendResult(interp, "Can't get Windows handle for Tk window", - NULL); + (char *)NULL); return TCL_ERROR; } @@ -2603,7 +2604,7 @@ static int GdiCopyBits( /* Given the HWND, we can get the window's device context. */ if ((src = GetWindowDC(hwnd)) == 0) { - Tcl_AppendResult(interp, "Can't get device context for Tk window", NULL); + Tcl_AppendResult(interp, "Can't get device context for Tk window", (char *)NULL); return TCL_ERROR; } @@ -2619,13 +2620,13 @@ static int GdiCopyBits( hgt = tl.bottom - tl.top; } else { if ((hgt = Tk_Height(workwin)) <= 0) { - Tcl_AppendResult(interp, "Can't get height of Tk window", NULL); + Tcl_AppendResult(interp, "Can't get height of Tk window", (char *)NULL); ReleaseDC(hwnd,src); return TCL_ERROR; } if ((wid = Tk_Width(workwin)) <= 0) { - Tcl_AppendResult(interp, "Can't get width of Tk window", NULL); + Tcl_AppendResult(interp, "Can't get width of Tk window", (char *)NULL); ReleaseDC(hwnd,src); return TCL_ERROR; } @@ -2688,14 +2689,14 @@ static int GdiCopyBits( /* GdiFlush();. */ if (!hDib) { - Tcl_AppendResult(interp, "Can't create DIB", NULL); + Tcl_AppendResult(interp, "Can't create DIB", (char *)NULL); ReleaseDC(hwnd,src); return TCL_ERROR; } lpDIBHdr = (LPBITMAPINFOHEADER) GlobalLock(hDib); if (!lpDIBHdr) { - Tcl_AppendResult(interp, "Can't get DIB header", NULL); + Tcl_AppendResult(interp, "Can't get DIB header", (char *)NULL); ReleaseDC(hwnd,src); return TCL_ERROR; } @@ -3970,7 +3971,7 @@ static int PrintSelectPrinter( WinprintData *dataPtr = (WinprintData *)clientData; if (dataPtr->printDC != NULL) { Tcl_AppendResult(interp, "device context still in use: call " - "_closedoc first", NULL); + "_closedoc first", (char *)NULL); return TCL_ERROR; } PRINTDLGW pd; @@ -4015,11 +4016,11 @@ static int PrintSelectPrinter( devnames = (LPDEVNAMES) GlobalLock(pd.hDevNames); if (! devmode) { Tcl_AppendResult(interp, "selected printer doesn't have extended info", - NULL); + (char *)NULL); return TCL_ERROR; } if (! devnames) { - Tcl_AppendResult(interp, "can't get device names", NULL); + Tcl_AppendResult(interp, "can't get device names", (char *)NULL); return TCL_ERROR; } @@ -4057,7 +4058,7 @@ static int PrintSelectPrinter( Tcl_NewIntObj(paper_height), 0); } else { Tcl_UnsetVar(interp, "::tk::print::printer_name", 0); - Tcl_AppendResult(interp, "selected printer doesn't have name", NULL); + Tcl_AppendResult(interp, "selected printer doesn't have name", (char *)NULL); DeleteDC(dataPtr->printDC); dataPtr->printDC = NULL; returnVal = TCL_ERROR; @@ -4091,7 +4092,7 @@ int PrintOpenPrinter( { WinprintData *dataPtr = (WinprintData *)clientData; if (dataPtr->printDC == NULL) { - Tcl_AppendResult(interp, "device context not initialized", NULL); + Tcl_AppendResult(interp, "device context not initialized", (char *)NULL); return TCL_ERROR; } Tcl_DString ds; @@ -4111,7 +4112,7 @@ int PrintOpenPrinter( Tcl_DStringInit(&ds); if ((OpenPrinterW(Tcl_UtfToWCharDString(printer, -1, &ds), (LPHANDLE)&dataPtr->printDC, NULL)) == FALSE) { - Tcl_AppendResult(interp, "unable to open printer", NULL); + Tcl_AppendResult(interp, "unable to open printer", (char *)NULL); Tcl_DStringFree(&ds); return TCL_ERROR; } @@ -4141,7 +4142,7 @@ int PrintClosePrinter( { WinprintData *dataPtr = (WinprintData *)clientData; if (dataPtr->printDC == NULL) { - Tcl_AppendResult(interp, "device context not initialized", NULL); + Tcl_AppendResult(interp, "device context not initialized", (char *)NULL); return TCL_ERROR; } @@ -4169,7 +4170,7 @@ int PrintOpenDoc( { WinprintData *dataPtr = (WinprintData *)clientData; if (dataPtr->printDC == NULL) { - Tcl_AppendResult(interp, "device context not initialized", NULL); + Tcl_AppendResult(interp, "device context not initialized", (char *)NULL); return TCL_ERROR; } int output = 0; @@ -4195,7 +4196,7 @@ int PrintOpenDoc( */ output = StartDocW(dataPtr->printDC, &dataPtr->di); if (output <= 0) { - Tcl_AppendResult(interp, "unable to start document", NULL); + Tcl_AppendResult(interp, "unable to start document", (char *)NULL); return TCL_ERROR; } @@ -4225,7 +4226,7 @@ int PrintOpenDoc( Tcl_SetObjResult(interp, Tcl_NewListObj(2, ret)); } else { Tcl_AppendResult(interp, "_opendoc: can't determine font ", - "width and height", NULL); + "width and height", (char *)NULL); return TCL_ERROR; } } @@ -4254,12 +4255,12 @@ int PrintCloseDoc( { WinprintData *dataPtr = (WinprintData *)clientData; if (dataPtr->printDC == NULL) { - Tcl_AppendResult(interp, "device context not initialized", NULL); + Tcl_AppendResult(interp, "device context not initialized", (char *)NULL); return TCL_ERROR; } if (EndDoc(dataPtr->printDC) <= 0) { - Tcl_AppendResult(interp, "unable to close document", NULL); + Tcl_AppendResult(interp, "unable to close document", (char *)NULL); return TCL_ERROR; } /* delete the font object that might be created as default */ @@ -4292,13 +4293,13 @@ int PrintOpenPage( { WinprintData *dataPtr = (WinprintData *)clientData; if (dataPtr->printDC == NULL) { - Tcl_AppendResult(interp, "device context not initialized", NULL); + Tcl_AppendResult(interp, "device context not initialized", (char *)NULL); return TCL_ERROR; } /*Start an individual page.*/ if (StartPage(dataPtr->printDC) <= 0) { - Tcl_AppendResult(interp, "unable to start page", NULL); + Tcl_AppendResult(interp, "unable to start page", (char *)NULL); return TCL_ERROR; } @@ -4326,12 +4327,12 @@ int PrintClosePage( { WinprintData *dataPtr = (WinprintData *)clientData; if (dataPtr->printDC == NULL) { - Tcl_AppendResult(interp, "device context not initialized", NULL); + Tcl_AppendResult(interp, "device context not initialized", (char *)NULL); return TCL_ERROR; } if (EndPage(dataPtr->printDC) <= 0) { - Tcl_AppendResult(interp, "unable to close page", NULL); + Tcl_AppendResult(interp, "unable to close page", (char *)NULL); return TCL_ERROR; } return TCL_OK; diff --git a/win/tkWinImage.c b/win/tkWinImage.c index 72f4d50..ee9507a 100644 --- a/win/tkWinImage.c +++ b/win/tkWinImage.c @@ -170,7 +170,7 @@ PutPixel( * Pixel is bit in MSBFirst order. */ - int mask = (0x80 >> (x%8)); + unsigned char mask = (0x80 >> (x%8)); if (pixel) { (*destPtr) |= mask; @@ -295,7 +295,7 @@ XGetImageZPixmap( HBITMAP hbmp, hbmpPrev; BITMAPINFO *bmInfo = NULL; HPALETTE hPal, hPalPrev1 = 0, hPalPrev2 = 0; - int size; + size_t size; unsigned int n; unsigned int depth; unsigned char *data; @@ -357,7 +357,7 @@ XGetImageZPixmap( bmInfo->bmiHeader.biWidth = width; bmInfo->bmiHeader.biHeight = -(int) height; bmInfo->bmiHeader.biPlanes = 1; - bmInfo->bmiHeader.biBitCount = depth; + bmInfo->bmiHeader.biBitCount = (WORD)depth; bmInfo->bmiHeader.biCompression = BI_RGB; bmInfo->bmiHeader.biSizeImage = 0; bmInfo->bmiHeader.biXPelsPerMeter = 0; diff --git a/win/tkWinInt.h b/win/tkWinInt.h index 36aa6a4..aaea20c 100644 --- a/win/tkWinInt.h +++ b/win/tkWinInt.h @@ -142,7 +142,7 @@ MODULE_SCOPE const int tkpWinBltModes[]; * Internal functions used by more than one source file. */ -#include "tkIntPlatDecls.h" +#include "tkIntPlatDecls.h" /* IWYU pragma: export */ #ifdef __cplusplus extern "C" { @@ -185,12 +185,14 @@ MODULE_SCOPE Tcl_Encoding TkWinGetUnicodeEncoding(void); MODULE_SCOPE void TkWinSetupSystemFonts(TkMainInfo *mainPtr); /* - * Values returned by TkWinGetPlatformTheme. + * Values used to be returned by TkWinGetPlatformTheme. */ -#define TK_THEME_WIN_CLASSIC 1 -#define TK_THEME_WIN_XP 2 -#define TK_THEME_WIN_VISTA 3 +#ifndef TK_NO_DEPRECATED +# define TK_THEME_WIN_CLASSIC 1 +# define TK_THEME_WIN_XP 2 +# define TK_THEME_WIN_VISTA 3 +#endif /* * The following is implemented in tkWinWm and used by tkWinEmbed.c diff --git a/win/tkWinKey.c b/win/tkWinKey.c index 61cb06e..b343ec5 100644 --- a/win/tkWinKey.c +++ b/win/tkWinKey.c @@ -97,7 +97,7 @@ TkpGetString( * result. */ { XKeyEvent *keyEv = &eventPtr->xkey; - int len; + Tcl_Size len; char buf[6]; Tcl_DStringInit(dsPtr); diff --git a/win/tkWinMenu.c b/win/tkWinMenu.c index 6d974b2..12bfef4 100644 --- a/win/tkWinMenu.c +++ b/win/tkWinMenu.c @@ -333,7 +333,7 @@ TkpNewMenu( if (winMenuHdl == NULL) { Tcl_SetObjResult(menuPtr->interp, Tcl_NewStringObj( "No more menus can be allocated.", TCL_INDEX_NONE)); - Tcl_SetErrorCode(menuPtr->interp, "TK", "MENU", "SYSTEM_RESOURCES", NULL); + Tcl_SetErrorCode(menuPtr->interp, "TK", "MENU", "SYSTEM_RESOURCES", (char *)NULL); return TCL_ERROR; } @@ -576,7 +576,8 @@ ReconfigureWindowsMenu( LPCWSTR lpNewItem; UINT flags; UINT itemID; - int i, count, systemMenu = 0, base; + Tcl_Size i, count; + int systemMenu = 0, base; Tcl_DString translatedText; if (NULL == winMenuHdl) { @@ -652,7 +653,7 @@ ReconfigureWindowsMenu( flags |= MF_MENUBREAK; } - itemID = PTR2INT(mePtr->platformEntryData); + itemID = (UINT)PTR2INT(mePtr->platformEntryData); if ((mePtr->type == CASCADE_ENTRY) && (mePtr->childMenuRefPtr != NULL) && (mePtr->childMenuRefPtr->menuPtr != NULL)) { @@ -672,7 +673,7 @@ ReconfigureWindowsMenu( * If the MF_POPUP flag is set, then the id is interpreted * as the handle of a submenu. */ - itemID = PTR2INT(childMenuHdl); + itemID = (UINT)PTR2INT(childMenuHdl); } } if ((menuPtr->menuType == MENUBAR) @@ -1925,18 +1926,16 @@ DrawMenuEntryAccelerator( * Draw disabled 3D text highlight only with the Win95/98 look. */ - if (TkWinGetPlatformTheme() != TK_THEME_WIN_XP) { - if ((mePtr->state == ENTRY_DISABLED) - && (menuPtr->disabledFgPtr != NULL) && (accel != NULL)) { - COLORREF oldFgColor = gc->foreground; + if ((mePtr->state == ENTRY_DISABLED) + && (menuPtr->disabledFgPtr != NULL) && (accel != NULL)) { + COLORREF oldFgColor = gc->foreground; - gc->foreground = GetSysColor(COLOR_3DHILIGHT); - if (!(mePtr->entryFlags & ENTRY_PLATFORM_FLAG1)) { - Tk_DrawChars(menuPtr->display, d, gc, tkfont, accel, - mePtr->accelLength, leftEdge + 1, baseline + 1); - } - gc->foreground = oldFgColor; + gc->foreground = GetSysColor(COLOR_3DHILIGHT); + if (!(mePtr->entryFlags & ENTRY_PLATFORM_FLAG1)) { + Tk_DrawChars(menuPtr->display, d, gc, tkfont, accel, + mePtr->accelLength, leftEdge + 1, baseline + 1); } + gc->foreground = oldFgColor; } if (accel != NULL) { @@ -2063,9 +2062,9 @@ DrawMenuSeparator( XPoint points[2]; Tk_3DBorder border; - points[0].x = x; - points[0].y = y + height / 2; - points[1].x = x + width - 1; + points[0].x = (short)x; + points[0].y = (short)(y + height / 2); + points[1].x = (short)(x + width - 1); points[1].y = points[0].y; border = Tk_Get3DBorderFromObj(menuPtr->tkwin, menuPtr->borderPtr); Tk_Draw3DPolygon(menuPtr->tkwin, d, border, points, 2, 1, @@ -2102,7 +2101,7 @@ DrawMenuUnderline( int height) /* Height of entry */ { if ((mePtr->underline >= 0) && (mePtr->labelPtr != NULL)) { - int len; + Tcl_Size len; len = Tcl_GetCharLength(mePtr->labelPtr); if (mePtr->underline < len) { @@ -2469,22 +2468,20 @@ DrawMenuEntryLabel( int baseline = y + (height + fmPtr->ascent - fmPtr->descent) / 2; const char *label = Tcl_GetString(mePtr->labelPtr); - if (TkWinGetPlatformTheme() != TK_THEME_WIN_XP) { - /* - * Win 95/98 systems draw disabled menu text with a 3D - * highlight, unless the menu item is highlighted, - */ + /* + * Win 95/98 systems draw disabled menu text with a 3D + * highlight, unless the menu item is highlighted, + */ - if ((mePtr->state == ENTRY_DISABLED) && - !(mePtr->entryFlags & ENTRY_PLATFORM_FLAG1)) { - COLORREF oldFgColor = gc->foreground; + if ((mePtr->state == ENTRY_DISABLED) && + !(mePtr->entryFlags & ENTRY_PLATFORM_FLAG1)) { + COLORREF oldFgColor = gc->foreground; - gc->foreground = GetSysColor(COLOR_3DHILIGHT); - Tk_DrawChars(menuPtr->display, d, gc, tkfont, label, - mePtr->labelLength, leftEdge + textXOffset + 1, - baseline + textYOffset + 1); - gc->foreground = oldFgColor; - } + gc->foreground = GetSysColor(COLOR_3DHILIGHT); + Tk_DrawChars(menuPtr->display, d, gc, tkfont, label, + mePtr->labelLength, leftEdge + textXOffset + 1, + baseline + textYOffset + 1); + gc->foreground = oldFgColor; } Tk_DrawChars(menuPtr->display, d, gc, tkfont, label, mePtr->labelLength, leftEdge + textXOffset, @@ -2570,21 +2567,21 @@ DrawTearoffEntry( return; } - points[0].x = x; - points[0].y = y + height/2; + points[0].x = (short)x; + points[0].y = (short)(y + height/2); points[1].y = points[0].y; segmentWidth = 6; maxX = x + width - 1; border = Tk_Get3DBorderFromObj(menuPtr->tkwin, menuPtr->borderPtr); while (points[0].x < maxX) { - points[1].x = points[0].x + segmentWidth; + points[1].x = points[0].x + (short)segmentWidth; if (points[1].x > maxX) { - points[1].x = maxX; + points[1].x = (short)maxX; } Tk_Draw3DPolygon(menuPtr->tkwin, d, border, points, 2, 1, TK_RELIEF_RAISED); - points[0].x += 2*segmentWidth; + points[0].x += (short)(2*segmentWidth); } } @@ -3383,10 +3380,6 @@ SetDefaults( metrics.cbSize = sizeof(metrics); - if (TkWinGetPlatformTheme() != TK_THEME_WIN_VISTA) { - metrics.cbSize -= sizeof(int); - } - SystemParametersInfoW(SPI_GETNONCLIENTMETRICS, metrics.cbSize, &metrics, 0); menuFont = CreateFontIndirectW(&metrics.lfMenuFont); diff --git a/win/tkWinPixmap.c b/win/tkWinPixmap.c index ad26c12..74e58c9 100644 --- a/win/tkWinPixmap.c +++ b/win/tkWinPixmap.c @@ -37,7 +37,7 @@ Tk_GetPixmap( int depth) { TkWinDrawable *newTwdPtr, *twdPtr; - int planes; + DWORD planes; Screen *screen; LastKnownRequestProcessed(display)++; @@ -59,11 +59,11 @@ Tk_GetPixmap( screen = ScreenOfDisplay(display, 0); planes = 1; if (depth == DefaultDepthOfScreen(screen)) { - planes = PTR2INT(screen->ext_data); + planes = (DWORD)PTR2INT(screen->ext_data); depth /= planes; } newTwdPtr->bitmap.handle = - CreateBitmap(width, height, (DWORD) planes, (DWORD) depth, NULL); + CreateBitmap(width, height, planes, (DWORD) depth, NULL); /* * CreateBitmap tries to use memory on the graphics card. If it fails, @@ -81,8 +81,8 @@ Tk_GetPixmap( bitmapInfo.bmiHeader.biSize = sizeof(bitmapInfo.bmiHeader); bitmapInfo.bmiHeader.biWidth = width; bitmapInfo.bmiHeader.biHeight = height; - bitmapInfo.bmiHeader.biPlanes = planes; - bitmapInfo.bmiHeader.biBitCount = depth; + bitmapInfo.bmiHeader.biPlanes = (WORD)planes; + bitmapInfo.bmiHeader.biBitCount = (WORD)depth; bitmapInfo.bmiHeader.biCompression = BI_RGB; bitmapInfo.bmiHeader.biSizeImage = 0; dc = GetDC(NULL); diff --git a/win/tkWinPointer.c b/win/tkWinPointer.c index 5ccd862..4dc6a89 100644 --- a/win/tkWinPointer.c +++ b/win/tkWinPointer.c @@ -49,10 +49,10 @@ static void MouseTimerProc(void *clientData); *---------------------------------------------------------------------- */ -int +unsigned int TkWinGetModifierState(void) { - int state = 0; + unsigned int state = 0; if (GetKeyState(VK_SHIFT) & 0x8000) { state |= ShiftMask; @@ -143,7 +143,7 @@ TkWinPointerEvent( } tkwin = Tk_HWNDToWindow(hwnd); - state = TkWinGetModifierState(); + state = (int)TkWinGetModifierState(); Tk_UpdatePointer(tkwin, pos.x, pos.y, state); @@ -525,7 +525,7 @@ XSetInputFocus( *---------------------------------------------------------------------- */ -int +size_t TkpChangeFocus( TkWindow *winPtr, /* Window that is to receive the X focus. */ int force) /* Non-zero means claim the focus even if it @@ -534,7 +534,8 @@ TkpChangeFocus( { TkDisplay *dispPtr = winPtr->dispPtr; Window focusWindow; - int dummy, serial; + int dummy; + size_t serial; TkWindow *winPtr2; if (!force) { diff --git a/win/tkWinRegion.c b/win/tkWinRegion.c index b6f87dc..cc9272c 100644 --- a/win/tkWinRegion.c +++ b/win/tkWinRegion.c @@ -300,6 +300,53 @@ TkpCopyRegion( { CombineRgn((HRGN)dst, (HRGN)src, NULL, RGN_COPY); } + +int +XUnionRegion( + Region srca, + Region srcb, + Region dr_return) +{ + CombineRgn((HRGN)dr_return, (HRGN)srca, (HRGN)srcb, RGN_OR); + return 1; +} + +int +XOffsetRegion( + Region r, + int dx, + int dy) +{ + OffsetRgn((HRGN)r, dx, dy); + return 1; +} + +Bool +XPointInRegion( + Region r, + int x, + int y) +{ + return PtInRegion((HRGN)r, x, y); +} + +Bool +XEqualRegion( + Region r1, + Region r2) +{ + return EqualRgn((HRGN)r1, (HRGN)r2); +} + +int +XXorRegion( + Region sra, + Region srb, + Region dr_return) +{ + CombineRgn((HRGN)dr_return, (HRGN)sra, (HRGN)srb, RGN_XOR); + return 0; +} /* * Local Variables: diff --git a/win/tkWinSend.c b/win/tkWinSend.c index 89ff7db..b4f57d5 100644 --- a/win/tkWinSend.c +++ b/win/tkWinSend.c @@ -147,7 +147,7 @@ Tk_SetAppName( if (FAILED(hr)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "failed to initialize the COM library", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "SEND", "COM", NULL); + Tcl_SetErrorCode(interp, "TK", "SEND", "COM", (char *)NULL); return ""; } tsdPtr->initialized = 1; @@ -334,7 +334,8 @@ Tk_SendObjCmd( }; const char *stringRep; int result = TCL_OK; - int i, async = 0, index; + int async = 0, index; + Tcl_Size i; /* * Process the command options. diff --git a/win/tkWinSysTray.c b/win/tkWinSysTray.c index 927f1fb..b44dce5 100644 --- a/win/tkWinSysTray.c +++ b/win/tkWinSysTray.c @@ -101,10 +101,12 @@ DrawXORMask( int x, y; /* Sanity checks */ - if (lpIcon == NULL) + if (lpIcon == NULL) { return FALSE; - if (lpIcon->lpBits == NULL) + } + if (lpIcon->lpBits == NULL) { return FALSE; + } /* Account for height*2 thing */ lpIcon->lpbi->bmiHeader.biHeight /= 2; @@ -152,10 +154,12 @@ DrawANDMask( int x, y; /* Sanity checks */ - if (lpIcon == NULL) + if (lpIcon == NULL) { return FALSE; - if (lpIcon->lpBits == NULL) + } + if (lpIcon->lpBits == NULL) { return FALSE; + } /* Need a bitmap header for the mono mask */ lpbi = ckalloc(sizeof(BITMAPINFO) + (2 * sizeof(RGBQUAD))); @@ -233,7 +237,8 @@ TaskbarOperation( Tcl_DString dst; Tcl_DStringInit(&dst); str = (WCHAR *)Tcl_UtfToWCharDString(Tcl_GetString(icoPtr->taskbar_txt), TCL_INDEX_NONE, &dst); - wcsncpy(ni.szTip, str, (Tcl_DStringLength(&dst) + 2) / 2); + wcsncpy(ni.szTip, str, sizeof(ni.szTip) / sizeof(WCHAR) - 1); + ni.szTip[sizeof(ni.szTip) / sizeof(WCHAR) - 1] = '\0'; Tcl_DStringFree(&dst); } else { ni.szTip[0] = 0; @@ -352,10 +357,11 @@ static IcoInfo * GetIcoPtr( Tcl_Interp *interp, IcoInterpInfo *icoInterpPtr, - const char *string) + Tcl_Obj *obj) { IcoInfo *icoPtr; unsigned id; + const char *string = Tcl_GetString(obj); const char *start; char *end; @@ -395,15 +401,15 @@ notfound: *---------------------------------------------------------------------- */ -static int +static size_t GetInt( - long theint, + Tcl_Size theint, char *buffer, size_t len) { - snprintf(buffer, len, "0x%lx", theint); + snprintf(buffer, len, "0x%" TCL_SIZE_MODIFIER "x", theint); buffer[len - 1] = 0; - return (int) strlen(buffer); + return strlen(buffer); } /* @@ -457,7 +463,7 @@ TaskbarExpandPercents( LPARAM lParam, char *before, char *after, - int *aftersize) + size_t *aftersize) { #define SPACELEFT (*aftersize-(dst-after)-1) #define AFTERLEN ((*aftersize>0)?(*aftersize*2):1024) @@ -467,7 +473,7 @@ TaskbarExpandPercents( dst = after; while (*before) { const char *ptr = before; - int len = 1; + size_t len = 1; if(*before == '%') { switch(before[1]){ case 'M': @@ -479,7 +485,7 @@ TaskbarExpandPercents( } /* case 'W': { before++; - len = (int)strlen(winstring); + len = strlen(winstring); ptr = winstring; break; } @@ -558,14 +564,15 @@ TaskbarExpandPercents( if (SPACELEFT < len) { char *newspace; ptrdiff_t dist = dst - after; - int alloclen = ALLOCLEN; + size_t alloclen = ALLOCLEN; newspace = (char *)ckalloc(alloclen); - if (dist>0) + if (dist>0) { memcpy(newspace, after, dist); + } if (after && *aftersize) { ckfree(after); } - *aftersize =alloclen; + *aftersize = alloclen; after = newspace; dst = after + dist; } @@ -573,7 +580,7 @@ TaskbarExpandPercents( memcpy(dst, ptr, len); } dst += len; - if ((dst-after)>(*aftersize-1)) { + if ((dst-after)>((Tcl_Size)*aftersize-1)) { printf("oops\n"); } before++; @@ -606,7 +613,7 @@ TaskbarEval( { const char *msgstring = "none"; char evalspace[200]; - int evalsize = 200; + size_t evalsize = 200; char *expanded; int fixup = 0; @@ -823,8 +830,9 @@ CreateTaskbarHandlerWindow(void) { static int registered = 0; HINSTANCE hInstance = GETHINSTANCE; if (!registered) { - if (!RegisterHandlerClass(hInstance)) + if (!RegisterHandlerClass(hInstance)) { return 0; + } registered = 1; } return CreateWindow(HANDLER_CLASS, "", WS_OVERLAPPED, 0, 0, @@ -915,7 +923,7 @@ WinSystrayCmd( int cmd, opt; HICON hIcon; - int i; + Tcl_Size i; IcoInterpInfo *icoInterpPtr = (IcoInterpInfo*) clientData; IcoInfo *icoPtr = NULL; @@ -943,7 +951,7 @@ WinSystrayCmd( Tcl_WrongNumArgs(interp, 2, objv, "id option value"); return TCL_ERROR; } - icoPtr = GetIcoPtr(interp, icoInterpPtr, Tcl_GetString(objv[2])); + icoPtr = GetIcoPtr(interp, icoInterpPtr, objv[2]); if (icoPtr == NULL) { return TCL_ERROR; } @@ -1032,7 +1040,7 @@ WinSystrayCmd( Tcl_WrongNumArgs(interp, 2, objv, "id"); return TCL_ERROR; } - icoPtr = GetIcoPtr(interp, icoInterpPtr, Tcl_GetString(objv[2])); + icoPtr = GetIcoPtr(interp, icoInterpPtr, objv[2]); if (icoPtr == NULL) { return TCL_ERROR; } @@ -1067,11 +1075,7 @@ WinSysNotifyCmd( { IcoInterpInfo *icoInterpPtr = (IcoInterpInfo*) clientData; IcoInfo *icoPtr; - Tcl_DString infodst; - Tcl_DString titledst; NOTIFYICONDATAW ni; - char *msgtitle; - char *msginfo; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "command ..."); @@ -1087,7 +1091,7 @@ WinSysNotifyCmd( return TCL_ERROR; } - icoPtr = GetIcoPtr(interp, icoInterpPtr, Tcl_GetString(objv[2])); + icoPtr = GetIcoPtr(interp, icoInterpPtr, objv[2]); if (icoPtr == NULL) { return TCL_ERROR; } @@ -1100,24 +1104,17 @@ WinSysNotifyCmd( ni.hIcon = icoPtr->hIcon; ni.dwInfoFlags = NIIF_INFO; /* Use a sane platform-specific icon here.*/ - msgtitle = Tcl_GetString(objv[3]); - msginfo = Tcl_GetString(objv[4]); - /* Balloon notification for system tray icon. */ - if (msgtitle != NULL) { - WCHAR *title; - Tcl_DStringInit(&titledst); - title = Tcl_UtfToWCharDString(msgtitle, TCL_INDEX_NONE, &titledst); - wcsncpy(ni.szInfoTitle, title, (Tcl_DStringLength(&titledst) + 2) / 2); - Tcl_DStringFree(&titledst); - } - if (msginfo != NULL) { - WCHAR *info; - Tcl_DStringInit(&infodst); - info = Tcl_UtfToWCharDString(msginfo, TCL_INDEX_NONE, &infodst); - wcsncpy(ni.szInfo, info, (Tcl_DStringLength(&infodst) + 2) / 2); - Tcl_DStringFree(&infodst); - } + Tcl_DString dst; + Tcl_DStringInit(&dst); + WCHAR *title = Tcl_UtfToWCharDString(Tcl_GetString(objv[3]), TCL_INDEX_NONE, &dst); + wcsncpy(ni.szInfoTitle, title, sizeof(ni.szInfoTitle) / sizeof(WCHAR) - 1); + ni.szInfoTitle[sizeof(ni.szInfoTitle) / sizeof(WCHAR) - 1] = '\0'; + Tcl_DStringSetLength(&dst, 0); + WCHAR *info = Tcl_UtfToWCharDString(Tcl_GetString(objv[4]), TCL_INDEX_NONE, &dst); + wcsncpy(ni.szInfo, info, sizeof(ni.szInfo) / sizeof(WCHAR) - 1); + ni.szInfo[sizeof(ni.szInfo) / sizeof(WCHAR) - 1] = '\0'; + Tcl_DStringFree(&dst); Shell_NotifyIconW(NIM_MODIFY, &ni); return TCL_OK; diff --git a/win/tkWinTest.c b/win/tkWinTest.c index 254ef8d..0c5e0f8 100644 --- a/win/tkWinTest.c +++ b/win/tkWinTest.c @@ -129,7 +129,7 @@ AppendSystemError( Tcl_Interp *interp, /* Current interpreter. */ DWORD error) /* Result code from error. */ { - int length; + Tcl_Size length; WCHAR *wMsgPtr, **wMsgPtrPtr = &wMsgPtr; const char *msg; char id[TCL_INTEGER_SPACE], msgBuf[24 + TCL_INTEGER_SPACE]; @@ -154,8 +154,8 @@ AppendSystemError( 0, NULL); if (length > 0) { wMsgPtr = (WCHAR *) LocalAlloc(LPTR, (length + 1) * sizeof(WCHAR)); - MultiByteToWideChar(CP_ACP, 0, msgPtr, length + 1, wMsgPtr, - length + 1); + MultiByteToWideChar(CP_ACP, 0, msgPtr, (int)length + 1, wMsgPtr, + (int)length + 1); LocalFree(msgPtr); } } @@ -191,7 +191,7 @@ AppendSystemError( } snprintf(id, sizeof(id), "%ld", error); - Tcl_SetErrorCode(interp, "WINDOWS", id, msg, NULL); + Tcl_SetErrorCode(interp, "WINDOWS", id, msg, (char *)NULL); Tcl_AppendToObj(resultPtr, msg, length); Tcl_SetObjResult(interp, resultPtr); @@ -453,24 +453,27 @@ TestfindwindowObjCmd( Tcl_DStringInit(&classString); windowClass = Tcl_UtfToWCharDString(Tcl_GetString(objv[2]), TCL_INDEX_NONE, &classString); } - if (title[0] == 0) + if (title[0] == 0) { title = NULL; + } /* We want find a window the belongs to us and not some other process */ hwnd = NULL; myPid = GetCurrentProcessId(); while (1) { DWORD pid, tid; hwnd = FindWindowExW(NULL, hwnd, windowClass, title); - if (hwnd == NULL) + if (hwnd == NULL) { break; + } tid = GetWindowThreadProcessId(hwnd, &pid); if (tid == 0) { /* Window has gone */ hwnd = NULL; break; } - if (pid == myPid) + if (pid == myPid) { break; /* Found it */ + } } if (hwnd == NULL) { @@ -517,8 +520,9 @@ TestgetwindowinfoObjCmd( return TCL_ERROR; } - if (Tcl_GetWideIntFromObj(interp, objv[1], &hwnd) != TCL_OK) + if (Tcl_GetWideIntFromObj(interp, objv[1], &hwnd) != TCL_OK) { return TCL_ERROR; + } cch = GetClassNameW((HWND)INT2PTR(hwnd), buf, cchBuf); if (cch == 0) { diff --git a/win/tkWinWm.c b/win/tkWinWm.c index 1b9a9c5..187c05f 100644 --- a/win/tkWinWm.c +++ b/win/tkWinWm.c @@ -549,24 +549,16 @@ MakeIconOrCursorFromResource( * Let the OS do the real work :) */ - hIcon = (HICON) CreateIconFromResourceEx(lpIcon->lpBits, - lpIcon->dwNumBytes, isIcon, 0x00030000, - (*(LPBITMAPINFOHEADER) lpIcon->lpBits).biWidth, - (*(LPBITMAPINFOHEADER) lpIcon->lpBits).biHeight/2, 0); + hIcon = (HICON)CreateIconFromResourceEx(lpIcon->lpBits, + lpIcon->dwNumBytes, isIcon, 0x00030000, 0, 0, 0); /* - * It failed, odds are good we're on NT so try the non-Ex way. + * It failed, the non-Ex way might work as a fallback. */ if (hIcon == NULL) { - /* - * We would break on NT if we try with a 16bpp image. - */ - - if (lpIcon->lpbi->bmiHeader.biBitCount != 16) { - hIcon = CreateIconFromResource(lpIcon->lpBits, lpIcon->dwNumBytes, - isIcon, 0x00030000); - } + hIcon = CreateIconFromResource(lpIcon->lpBits, lpIcon->dwNumBytes, + isIcon, 0x00030000); } return hIcon; } @@ -795,7 +787,7 @@ WinSetIcon( if (InitWindowClass(titlebaricon) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "Unable to set icon", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "WM", "ICON", "FAILED", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "ICON", "FAILED", (char *)NULL); return TCL_ERROR; } } else { @@ -852,7 +844,7 @@ WinSetIcon( if (hwnd == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "Can't set icon; window has no wrapper.", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "WM", "ICON", "WRAPPER", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "ICON", "WRAPPER", (char *)NULL); return TCL_ERROR; } } @@ -1105,6 +1097,50 @@ ReadIconFromFile( */ static BOOL +SetSizeAndColorFromHICON( /* Helper for AdjustIconImagePointers */ + HICON hicon, + LPICONIMAGE lpImage) +{ + ICONINFO info; + BOOL bRes; + BITMAP bmp; + + memset(&info, 0, sizeof(info)); + + bRes = GetIconInfo(hicon, &info); + if (!bRes) { + return FALSE; + } + + if (info.hbmColor) { + const int nWrittenBytes = GetObject(info.hbmColor, sizeof(bmp), &bmp); + + if (nWrittenBytes > 0) { + lpImage->Width = bmp.bmWidth; + lpImage->Height = bmp.bmHeight; + lpImage->Colors = bmp.bmBitsPixel; + } + } else if (info.hbmMask) { + // Icon has no color plane, image data stored in mask + const int nWrittenBytes = GetObject(info.hbmMask, sizeof(bmp), &bmp); + + if (nWrittenBytes > 0) { + lpImage->Width = bmp.bmWidth; + lpImage->Height = bmp.bmHeight / 2; + lpImage->Colors = 1; + } + } + + if (info.hbmColor) { + DeleteObject(info.hbmColor); + } + if (info.hbmMask) { + DeleteObject(info.hbmMask); + } + return TRUE; +} + +static BOOL AdjustIconImagePointers( LPICONIMAGE lpImage) { @@ -1123,24 +1159,10 @@ AdjustIconImagePointers( lpImage->lpbi = (LPBITMAPINFO) lpImage->lpBits; /* - * Width - simple enough. - */ - - lpImage->Width = lpImage->lpbi->bmiHeader.biWidth; - - /* - * Icons are stored in funky format where height is doubled so account for - * that. + * Width, height, and number of colors. */ - lpImage->Height = (lpImage->lpbi->bmiHeader.biHeight)/2; - - /* - * How many colors? - */ - - lpImage->Colors = lpImage->lpbi->bmiHeader.biPlanes - * lpImage->lpbi->bmiHeader.biBitCount; + SetSizeAndColorFromHICON(lpImage->hIcon, lpImage); /* * XOR bits follow the header and color table. @@ -1153,7 +1175,7 @@ AdjustIconImagePointers( */ lpImage->lpAND = lpImage->lpXOR + - lpImage->Height*BytesPerLine((LPBITMAPINFOHEADER) lpImage->lpbi); + lpImage->Height * BytesPerLine((LPBITMAPINFOHEADER) lpImage->lpbi); return TRUE; } @@ -1483,7 +1505,7 @@ ReadIconOrCursorFromFile( if (dwBytesRead != lpIR->nNumImages * sizeof(ICONDIRENTRY)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "error reading file: %s", Tcl_PosixError(interp))); - Tcl_SetErrorCode(interp, "TK", "WM", "ICON", "READ", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "ICON", "READ", (char *)NULL); Tcl_Close(NULL, channel); ckfree(lpIDE); ckfree(lpIR); @@ -1533,17 +1555,17 @@ ReadIconOrCursorFromFile( } /* - * Set the internal pointers appropriately. + * Create the icon from the resource, and set the internal pointers appropriately. */ + lpIR->IconImages[i].hIcon = + MakeIconOrCursorFromResource(&lpIR->IconImages[i], isIcon); if (!AdjustIconImagePointers(&lpIR->IconImages[i])) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "Error converting to internal format", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "WM", "ICON", "FORMAT", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "ICON", "FORMAT", (char *)NULL); goto readError; } - lpIR->IconImages[i].hIcon = - MakeIconOrCursorFromResource(&lpIR->IconImages[i], isIcon); } /* @@ -2552,8 +2574,9 @@ TkWmDeadWindow( } } } - if (wmPtr->numTransients != 0) + if (wmPtr->numTransients != 0) { Tcl_Panic("numTransients should be 0"); + } if (wmPtr->title != NULL) { ckfree(wmPtr->title); @@ -2916,7 +2939,7 @@ WmAspectCmd( if ((numer1 <= 0) || (denom1 <= 0) || (numer2 <= 0) || (denom2 <= 0)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "aspect number can't be <= 0", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "VALUE", "ASPECT", NULL); + Tcl_SetErrorCode(interp, "TK", "VALUE", "ASPECT", (char *)NULL); return TCL_ERROR; } wmPtr->minAspect.x = numer1; @@ -3035,14 +3058,14 @@ WmAttributesCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't set topmost flag on %s: it is an embedded window", winPtr->pathName)); - Tcl_SetErrorCode(interp, "TK", "WM", "ATTR", "TOPMOST", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "ATTR", "TOPMOST", (char *)NULL); return TCL_ERROR; } } else if (i == 3) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad attribute \"%s\": must be -alpha, -disabled, -fullscreen, -toolwindow, -topmost, or -transparentcolor", string)); - Tcl_SetErrorCode(interp, "TK", "WM", "ATTR", "UNRECOGNIZED", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "ATTR", "UNRECOGNIZED", (char *)NULL); return TCL_ERROR; } else { goto configArgs; @@ -3217,7 +3240,7 @@ WmAttributesCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't set fullscreen attribute for \"%s\":" " max width/height is too small", winPtr->pathName)); - Tcl_SetErrorCode(interp, "TK", "WM", "ATTR", "SMALL_MAX", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "ATTR", "SMALL_MAX", (char *)NULL); return TCL_ERROR; } } @@ -3497,7 +3520,7 @@ WmDeiconifyCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't deiconify %s: it is an icon for %s", Tcl_GetString(objv[2]), Tk_PathName(wmPtr->iconFor))); - Tcl_SetErrorCode(interp, "TK", "WM", "DEICONIFY", "ICON", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "DEICONIFY", "ICON", (char *)NULL); return TCL_ERROR; } if (winPtr->flags & TK_EMBEDDED) { @@ -3505,7 +3528,7 @@ WmDeiconifyCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't deiconify %s: the container does not support the request", winPtr->pathName)); - Tcl_SetErrorCode(interp, "TK", "WM", "COMMUNICATION", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "COMMUNICATION", (char *)NULL); return TCL_ERROR; } return TCL_OK; @@ -3801,25 +3824,25 @@ WmGridCmd( if (reqWidth < 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "baseWidth can't be < 0", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "VALUE", "GRID", NULL); + Tcl_SetErrorCode(interp, "TK", "VALUE", "GRID", (char *)NULL); return TCL_ERROR; } if (reqHeight < 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "baseHeight can't be < 0", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "VALUE", "GRID", NULL); + Tcl_SetErrorCode(interp, "TK", "VALUE", "GRID", (char *)NULL); return TCL_ERROR; } if (widthInc <= 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "widthInc can't be <= 0", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "VALUE", "GRID", NULL); + Tcl_SetErrorCode(interp, "TK", "VALUE", "GRID", (char *)NULL); return TCL_ERROR; } if (heightInc <= 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "heightInc can't be <= 0", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "VALUE", "GRID", NULL); + Tcl_SetErrorCode(interp, "TK", "VALUE", "GRID", (char *)NULL); return TCL_ERROR; } Tk_SetGrid((Tk_Window) winPtr, reqWidth, reqHeight, widthInc, @@ -4045,7 +4068,7 @@ WmIconbitmapCmd( if (strcmp(argv3, "-default")) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "illegal option \"%s\" must be \"-default\"", argv3)); - Tcl_SetErrorCode(interp, "TK", "WM", "ICONBITMAP", "OPTION",NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "ICONBITMAP", "OPTION", (char *)NULL); return TCL_ERROR; } useWinPtr = NULL; @@ -4175,7 +4198,7 @@ WmIconifyCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't iconify \"%s\": the container does not support the request", winPtr->pathName)); - Tcl_SetErrorCode(interp, "TK", "WM", "ICONIFY", "EMBEDDED", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "ICONIFY", "EMBEDDED", (char *)NULL); return TCL_ERROR; } } @@ -4191,14 +4214,14 @@ WmIconifyCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't iconify \"%s\": it is a transient", winPtr->pathName)); - Tcl_SetErrorCode(interp, "TK", "WM", "ICONIFY", "TRANSIENT", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "ICONIFY", "TRANSIENT", (char *)NULL); return TCL_ERROR; } if (wmPtr->iconFor != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't iconify \"%s\": it is an icon for \"%s\"", winPtr->pathName, Tk_PathName(wmPtr->iconFor))); - Tcl_SetErrorCode(interp, "TK", "WM", "ICONIFY", "ICON", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "ICONIFY", "ICON", (char *)NULL); return TCL_ERROR; } TkpWmSetState(winPtr, IconicState); @@ -4374,7 +4397,7 @@ WmIconphotoCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't use \"%s\" as iconphoto: not a photo image", Tcl_GetString(objv[i]))); - Tcl_SetErrorCode(interp, "TK", "WM", "ICONPHOTO", "PHOTO", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "ICONPHOTO", "PHOTO", (char *)NULL); return TCL_ERROR; } } @@ -4402,7 +4425,7 @@ WmIconphotoCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "failed to create an iconphoto with image \"%s\"", Tcl_GetString(objv[i]))); - Tcl_SetErrorCode(interp, "TK", "WM", "ICONPHOTO", "ICON", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "ICONPHOTO", "ICON", (char *)NULL); return TCL_ERROR; } lpIR->IconImages[i-startObj].Width = width; @@ -4548,7 +4571,7 @@ WmIconwindowCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't use %s as icon window: not at top level", Tcl_GetString(objv[3]))); - Tcl_SetErrorCode(interp, "TK", "WM", "ICONWINDOW", "INNER", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "ICONWINDOW", "INNER", (char *)NULL); return TCL_ERROR; } wmPtr2 = ((TkWindow *) tkwin2)->wmInfoPtr; @@ -4556,7 +4579,7 @@ WmIconwindowCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s is already an icon for %s", Tcl_GetString(objv[3]), Tk_PathName(wmPtr2->iconFor))); - Tcl_SetErrorCode(interp, "TK", "WM", "ICONWINDOW", "ICON", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "ICONWINDOW", "ICON", (char *)NULL); return TCL_ERROR; } if (wmPtr->icon != NULL) { @@ -4627,7 +4650,7 @@ WmManageCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "window \"%s\" is not manageable: must be a frame," " labelframe or toplevel", Tk_PathName(frameWin))); - Tcl_SetErrorCode(interp, "TK", "WM", "MANAGE", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "MANAGE", (char *)NULL); return TCL_ERROR; } TkFocusSplit(winPtr); @@ -4788,7 +4811,7 @@ WmOverrideredirectCmd( if (curValue < 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "Container does not support overrideredirect", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "WM", "COMMUNICATION", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "COMMUNICATION", (char *)NULL); return TCL_ERROR; } } else { @@ -5184,21 +5207,21 @@ WmStackorderCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "window \"%s\" isn't a top-level window", winPtr2->pathName)); - Tcl_SetErrorCode(interp, "TK", "WM", "STACK", "TOPLEVEL", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "STACK", "TOPLEVEL", (char *)NULL); return TCL_ERROR; } if (!Tk_IsMapped(winPtr)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "window \"%s\" isn't mapped", winPtr->pathName)); - Tcl_SetErrorCode(interp, "TK", "WM", "STACK", "MAPPED", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "STACK", "MAPPED", (char *)NULL); return TCL_ERROR; } if (!Tk_IsMapped(winPtr2)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "window \"%s\" isn't mapped", winPtr2->pathName)); - Tcl_SetErrorCode(interp, "TK", "WM", "STACK", "MAPPED", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "STACK", "MAPPED", (char *)NULL); return TCL_ERROR; } @@ -5211,7 +5234,7 @@ WmStackorderCmd( if (windows == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "TkWmStackorderToplevel failed", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TK", "WM", "COMMUNICATION", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "COMMUNICATION", (char *)NULL); return TCL_ERROR; } @@ -5288,7 +5311,7 @@ WmStateCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't change state of %s: it is an icon for %s", Tcl_GetString(objv[2]), Tk_PathName(wmPtr->iconFor))); - Tcl_SetErrorCode(interp, "TK", "WM", "STATE", "ICON", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "STATE", "ICON", (char *)NULL); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[3], optionStrings, @@ -5320,7 +5343,7 @@ WmStateCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't change state of %s: the container does not support the request", winPtr->pathName)); - Tcl_SetErrorCode(interp, "TK", "WM", "COMMUNICATION", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "COMMUNICATION", (char *)NULL); return TCL_ERROR; } return TCL_OK; @@ -5532,7 +5555,7 @@ WmTransientCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't make \"%s\" a transient: it is an icon for %s", Tcl_GetString(objv[2]), Tk_PathName(wmPtr->iconFor))); - Tcl_SetErrorCode(interp, "TK", "WM", "TRANSIENT", "ICON", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "TRANSIENT", "ICON", (char *)NULL); return TCL_ERROR; } @@ -5542,7 +5565,7 @@ WmTransientCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't make \"%s\" a container: it is an icon for %s", Tcl_GetString(objv[3]), Tk_PathName(wmPtr2->iconFor))); - Tcl_SetErrorCode(interp, "TK", "WM", "TRANSIENT", "ICON", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "TRANSIENT", "ICON", (char *)NULL); return TCL_ERROR; } for (w = containerPtr; w != NULL && w->wmInfoPtr != NULL; @@ -5551,7 +5574,7 @@ WmTransientCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't set \"%s\" as container: would cause management loop", Tk_PathName(containerPtr))); - Tcl_SetErrorCode(interp, "TK", "WM", "TRANSIENT", "SELF", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "TRANSIENT", "SELF", (char *)NULL); return TCL_ERROR; } } @@ -5624,7 +5647,7 @@ WmWithdrawCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't withdraw %s: it is an icon for %s", Tcl_GetString(objv[2]), Tk_PathName(wmPtr->iconFor))); - Tcl_SetErrorCode(interp, "TK", "WM", "WITHDRAW", "ICON", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "WITHDRAW", "ICON", (char *)NULL); return TCL_ERROR; } @@ -5633,7 +5656,7 @@ WmWithdrawCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't withdraw %s: the container does not support the request", Tcl_GetString(objv[2]))); - Tcl_SetErrorCode(interp, "TK", "WM", "COMMUNICATION", NULL); + Tcl_SetErrorCode(interp, "TK", "WM", "COMMUNICATION", (char *)NULL); return TCL_ERROR; } } else { @@ -6353,7 +6376,7 @@ ParseGeometry( error: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad geometry specifier \"%s\"", string)); - Tcl_SetErrorCode(interp, "TK", "VALUE", "GEOMETRY", NULL); + Tcl_SetErrorCode(interp, "TK", "VALUE", "GEOMETRY", (char *)NULL); return TCL_ERROR; } diff --git a/win/tkWinX.c b/win/tkWinX.c index 819f9df..a6aea8e 100644 --- a/win/tkWinX.c +++ b/win/tkWinX.c @@ -87,7 +87,6 @@ static const char winScreenName[] = ":0"; /* Default name of windows display. */ static HINSTANCE tkInstance = NULL; /* Application instance handle. */ static int childClassInitialized; /* Registered child class? */ static WNDCLASSW childClass; /* Window class for child windows. */ -static int tkWinTheme = 0; /* See TkWinGetPlatformTheme */ static Tcl_Encoding keyInputEncoding = NULL; /* The current character encoding for * keyboard input */ @@ -334,69 +333,6 @@ TkWinXCleanup( /* *---------------------------------------------------------------------- * - * TkWinGetPlatformTheme -- - * - * Return the Windows drawing style we should be using. - * - * Results: - * The return value is one of: - * TK_THEME_WIN_CLASSIC 95/98/NT or XP in classic mode - * TK_THEME_WIN_XP XP not in classic mode - * TK_THEME_WIN_VISTA Vista or higher - * - *---------------------------------------------------------------------- - */ - -int -TkWinGetPlatformTheme(void) -{ - if (tkWinTheme == 0) { - OSVERSIONINFOW os; - - os.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW); - GetVersionExW(&os); - - if (os.dwPlatformId != VER_PLATFORM_WIN32_NT) { - Tcl_Panic("Windows NT is the only supported platform"); - } - - /* - * Set tkWinTheme to be TK_THEME_WIN_(CLASSIC|XP|VISTA). The - * TK_THEME_WIN_CLASSIC could be set even when running under XP if the - * windows classic theme was selected. - */ - if (os.dwMajorVersion == 5 && os.dwMinorVersion >= 1) { - HKEY hKey; - LPCWSTR szSubKey = L"Control Panel\\Appearance"; - LPCWSTR szCurrent = L"Current"; - DWORD dwSize = 200; - WCHAR pBuffer[200]; - - memset(pBuffer, 0, dwSize); - if (RegOpenKeyExW(HKEY_CURRENT_USER, szSubKey, 0L, - KEY_READ, &hKey) != ERROR_SUCCESS) { - tkWinTheme = TK_THEME_WIN_XP; - } else { - RegQueryValueExW(hKey, szCurrent, NULL, NULL, (LPBYTE) pBuffer, &dwSize); - RegCloseKey(hKey); - if (wcscmp(pBuffer, L"Windows Standard") == 0) { - tkWinTheme = TK_THEME_WIN_CLASSIC; - } else { - tkWinTheme = TK_THEME_WIN_XP; - } - } - } else if (os.dwMajorVersion > 5) { - tkWinTheme = TK_THEME_WIN_VISTA; - } else { - tkWinTheme = TK_THEME_WIN_CLASSIC; - } - } - return tkWinTheme; -} - -/* - *---------------------------------------------------------------------- - * * TkGetDefaultScreenName -- * * Returns the name of the screen that Tk should use during @@ -1196,7 +1132,7 @@ GenerateXEvent( event.key.nbytes = 0; event.x.xkey.state = state; event.x.xany.serial = scrollCounter++; - event.x.xkey.keycode = (unsigned int)(-(delta << 16)); + event.x.xkey.keycode = -((unsigned int)delta << 16); } else { event.x.type = MouseWheelEvent; event.x.xany.send_event = -1; diff --git a/win/ttkWinMonitor.c b/win/ttkWinMonitor.c index 32d2a07..217730f 100644 --- a/win/ttkWinMonitor.c +++ b/win/ttkWinMonitor.c @@ -127,7 +127,7 @@ WndProc(HWND hwnd, UINT msg, WPARAM wp, LPARAM lp) * the theme to 'winnative' (by setting the ui to 'best performance'), * which is a machine-wide change, and then sign back on to the original user. * Ttk_UseTheme needs to be executed again in order to process the fallback - * from vista/xpnative to winnative. + * from vista to winnative. */ theme = Ttk_GetCurrentTheme(interp); @@ -145,7 +145,7 @@ WndProc(HWND hwnd, UINT msg, WPARAM wp, LPARAM lp) */ MODULE_SCOPE int TtkWinTheme_Init(Tcl_Interp *, HWND hwnd); -MODULE_SCOPE int TtkXPTheme_Init(Tcl_Interp *, HWND hwnd); +MODULE_SCOPE int TtkWinVistaTheme_Init(Tcl_Interp *, HWND hwnd); MODULE_SCOPE int Ttk_WinPlatformInit(Tcl_Interp *interp); MODULE_SCOPE int Ttk_WinPlatformInit(Tcl_Interp *interp) @@ -156,7 +156,7 @@ MODULE_SCOPE int Ttk_WinPlatformInit(Tcl_Interp *interp) Ttk_RegisterCleanup(interp, hwnd, DestroyThemeMonitorWindow); TtkWinTheme_Init(interp, hwnd); - TtkXPTheme_Init(interp, hwnd); + TtkWinVistaTheme_Init(interp, hwnd); return TCL_OK; } diff --git a/win/ttkWinTheme.c b/win/ttkWinTheme.c index c97d670..0b63311 100644 --- a/win/ttkWinTheme.c +++ b/win/ttkWinTheme.c @@ -105,8 +105,8 @@ typedef struct { #define BASE_DIM 16 #define _FIXEDSIZE 0x80000000UL #define _HALFMETRIC 0x40000000UL -#define FIXEDSIZE(id) (id|_FIXEDSIZE) -#define HALFMETRIC(id) (id|_HALFMETRIC) +#define FIXEDSIZE(id) ((id)|_FIXEDSIZE) +#define HALFMETRIC(id) ((id)|_HALFMETRIC) #define GETMETRIC(m) \ ((m) & _FIXEDSIZE ? (int)((m) & ~_FIXEDSIZE) : GetSystemMetrics((m)&0xFFFFFFF)) @@ -158,14 +158,14 @@ static void FrameControlElementSize( if ((p->cxId & _FIXEDSIZE) && cx == BASE_DIM) { double scalingLevel = TkScalingLevel(tkwin); - cx *= scalingLevel; - cy *= scalingLevel; + cx = (int)(cx * scalingLevel); + cy = (int)(cy * scalingLevel); /* * Update the corresponding element of the array FrameControlElements */ - p->cxId = FIXEDSIZE(cx); - p->cyId = FIXEDSIZE(cy); + p->cxId = FIXEDSIZE((unsigned long)cx); + p->cyId = FIXEDSIZE((unsigned long)cy); } if (p->cxId & _HALFMETRIC) cx /= 2; @@ -189,8 +189,8 @@ static void FrameControlElementDraw( HDC hdc = TkWinGetDrawableDC(Tk_Display(tkwin), d, &dcState); DrawFrameControl(hdc, &rc, - elementData->classId, - elementData->partId|Ttk_StateTableLookup(elementData->stateMap, state)); + (UINT)elementData->classId, + (UINT)(elementData->partId|Ttk_StateTableLookup(elementData->stateMap, state))); TkWinReleaseDrawableDC(d, hdc, &dcState); } @@ -223,8 +223,8 @@ static void BorderElementSize( TCL_UNUSED(int *), /* heightPtr */ Ttk_Padding *paddingPtr) { - paddingPtr->left = paddingPtr->right = GetSystemMetrics(SM_CXEDGE); - paddingPtr->top = paddingPtr->bottom = GetSystemMetrics(SM_CYEDGE); + paddingPtr->left = paddingPtr->right = (short)GetSystemMetrics(SM_CXEDGE); + paddingPtr->top = paddingPtr->bottom = (short)GetSystemMetrics(SM_CYEDGE); } static void BorderElementDraw( @@ -282,8 +282,8 @@ static void FieldElementSize( TCL_UNUSED(int *), /* heightPtr */ Ttk_Padding *paddingPtr) { - paddingPtr->left = paddingPtr->right = GetSystemMetrics(SM_CXEDGE); - paddingPtr->top = paddingPtr->bottom = GetSystemMetrics(SM_CYEDGE); + paddingPtr->left = paddingPtr->right = (short)GetSystemMetrics(SM_CXEDGE); + paddingPtr->top = paddingPtr->bottom = (short)GetSystemMetrics(SM_CYEDGE); } static void FieldElementDraw( @@ -352,8 +352,8 @@ static void ButtonBorderElementSize( Tk_GetReliefFromObj(NULL, bd->reliefObj, &relief); Ttk_GetButtonDefaultStateFromObj(NULL, bd->defaultStateObj, &defaultState); - cx = GetSystemMetrics(SM_CXEDGE); - cy = GetSystemMetrics(SM_CYEDGE); + cx = (short)GetSystemMetrics(SM_CXEDGE); + cy = (short)GetSystemMetrics(SM_CYEDGE); /* Space for default indicator: */ @@ -366,7 +366,7 @@ static void ButtonBorderElementSize( cx += 2; cy += 2; - *paddingPtr = Ttk_MakePadding(cx,cy,cx,cy); + *paddingPtr = Ttk_MakePadding(cx, cy, cx, cy); } static void ButtonBorderElementDraw( @@ -391,7 +391,7 @@ static void ButtonBorderElementDraw( XColor *highlightColor = Tk_GetColorFromObj(tkwin, bd->highlightColorObj); GC gc = Tk_GCForColor(highlightColor, d); - XDrawRectangle(Tk_Display(tkwin), d, gc, b.x,b.y,b.width-1,b.height-1); + XDrawRectangle(Tk_Display(tkwin), d, gc, b.x, b.y, (UINT)(b.width - 1), (UINT)(b.height - 1)); } if (defaultState != TTK_BUTTON_DEFAULT_DISABLED) { ++b.x; ++b.y; b.width -= 2; b.height -= 2; @@ -402,7 +402,7 @@ static void ButtonBorderElementDraw( rc = BoxToRect(b); DrawFrameControl(hdc, &rc, DFC_BUTTON, /* classId */ - DFCS_BUTTONPUSH | Ttk_StateTableLookup(pushbutton_statemap, state)); + (UINT)(DFCS_BUTTONPUSH | Ttk_StateTableLookup(pushbutton_statemap, state))); TkWinReleaseDrawableDC(d, hdc, &dcState); @@ -489,7 +489,7 @@ static void FillFocusElementDraw( FillFocusElement *focus = (FillFocusElement *)elementRecord; XColor *fillColor = Tk_GetColorFromObj(tkwin, focus->fillColorObj); GC gc = Tk_GCForColor(fillColor, d); - XFillRectangle(Tk_Display(tkwin), d, gc, b.x, b.y, b.width, b.height); + XFillRectangle(Tk_Display(tkwin), d, gc, b.x, b.y, (unsigned)b.width, (unsigned)b.height); TkWinDrawDottedRect(Tk_Display(tkwin), d, -1, b.x, b.y, b.width, b.height); @@ -638,8 +638,9 @@ static void ThumbElementDraw( HDC hdc; /* Windows doesn't show a thumb when the scrollbar is disabled */ - if (state & TTK_STATE_DISABLED) + if (state & TTK_STATE_DISABLED) { return; + } hdc = TkWinGetDrawableDC(Tk_Display(tkwin), d, &dcState); DrawEdge(hdc, &rc, EDGE_RAISED, BF_RECT | BF_MIDDLE); @@ -783,7 +784,7 @@ static void TabElementDraw( Tk_3DBorder border = Tk_Get3DBorderFromObj(tkwin, tab->backgroundObj); XPoint pts[6]; double scalingLevel = TkScalingLevel(tkwin); - int cut = round(2 * scalingLevel); + int cut = (int)round(2 * scalingLevel); Display *disp = Tk_Display(tkwin); int borderWidth = 1; @@ -816,36 +817,36 @@ static void TabElementDraw( switch (nbTabsStickBit) { default: case TTK_STICK_S: - pts[0].x = b.x; pts[0].y = b.y + b.height-1; - pts[1].x = b.x; pts[1].y = b.y + cut; - pts[2].x = b.x + cut; pts[2].y = b.y; - pts[3].x = b.x + b.width-1 - cut; pts[3].y = b.y; - pts[4].x = b.x + b.width-1; pts[4].y = b.y + cut; - pts[5].x = b.x + b.width-1; pts[5].y = b.y + b.height; + pts[0].x = (short)b.x; pts[0].y = (short)(b.y + b.height - 1); + pts[1].x = (short)b.x; pts[1].y = (short)(b.y + cut); + pts[2].x = (short)(b.x + cut); pts[2].y = (short)b.y; + pts[3].x = (short)(b.x + b.width - 1 - cut); pts[3].y = (short)b.y; + pts[4].x = (short)(b.x + b.width - 1); pts[4].y = (short)(b.y + cut); + pts[5].x = (short)(b.x + b.width - 1); pts[5].y = (short)(b.y + b.height); break; case TTK_STICK_N: - pts[0].x = b.x; pts[0].y = b.y; - pts[1].x = b.x; pts[1].y = b.y + b.height-1 - cut; - pts[2].x = b.x + cut; pts[2].y = b.y + b.height-1; - pts[3].x = b.x + b.width-1 - cut; pts[3].y = b.y + b.height-1; - pts[4].x = b.x + b.width-1; pts[4].y = b.y + b.height-1 - cut; - pts[5].x = b.x + b.width-1; pts[5].y = b.y-1; + pts[0].x = (short)b.x; pts[0].y = (short)b.y; + pts[1].x = (short)b.x; pts[1].y = (short)(b.y + b.height - 1 - cut); + pts[2].x = (short)(b.x + cut); pts[2].y = (short)(b.y + b.height - 1); + pts[3].x = (short)(b.x + b.width - 1 - cut); pts[3].y = (short)(b.y + b.height - 1); + pts[4].x = (short)(b.x + b.width - 1); pts[4].y = (short)(b.y + b.height - 1 - cut); + pts[5].x = (short)(b.x + b.width - 1); pts[5].y = (short)(b.y - 1); break; case TTK_STICK_E: - pts[0].x = b.x + b.width-1; pts[0].y = b.y; - pts[1].x = b.x + cut; pts[1].y = b.y; - pts[2].x = b.x; pts[2].y = b.y + cut; - pts[3].x = b.x; pts[3].y = b.y + b.height-1 - cut; - pts[4].x = b.x + cut; pts[4].y = b.y + b.height-1; - pts[5].x = b.x + b.width; pts[5].y = b.y + b.height-1; + pts[0].x = (short)(b.x + b.width - 1); pts[0].y = (short)b.y; + pts[1].x = (short)(b.x + cut); pts[1].y = (short)b.y; + pts[2].x = (short)b.x; pts[2].y = (short)(b.y + cut); + pts[3].x = (short)b.x; pts[3].y = (short)(b.y + b.height - 1 - cut); + pts[4].x = (short)(b.x + cut); pts[4].y = (short)(b.y + b.height - 1); + pts[5].x = (short)(b.x + b.width); pts[5].y = (short)(b.y + b.height - 1); break; case TTK_STICK_W: - pts[0].x = b.x; pts[0].y = b.y; - pts[1].x = b.x + b.width-1 - cut; pts[1].y = b.y; - pts[2].x = b.x + b.width-1; pts[2].y = b.y + cut; - pts[3].x = b.x + b.width-1; pts[3].y = b.y + b.height-1 - cut; - pts[4].x = b.x + b.width-1 - cut; pts[4].y = b.y + b.height-1; - pts[5].x = b.x-1; pts[5].y = b.y + b.height-1; + pts[0].x = (short)b.x; pts[0].y = (short)b.y; + pts[1].x = (short)(b.x + b.width - 1 - cut); pts[1].y = (short)b.y; + pts[2].x = (short)(b.x + b.width - 1); pts[2].y = (short)(b.y + cut); + pts[3].x = (short)(b.x + b.width - 1); pts[3].y = (short)(b.y + b.height - 1 - cut); + pts[4].x = (short)(b.x + b.width - 1 - cut); pts[4].y = (short)(b.y + b.height - 1); + pts[5].x = (short)(b.x - 1); pts[5].y = (short)(b.y + b.height - 1); break; } @@ -897,8 +898,8 @@ static void ClientElementSize( TCL_UNUSED(int *), /* heightPtr */ Ttk_Padding *paddingPtr) { - paddingPtr->left = paddingPtr->right = GetSystemMetrics(SM_CXEDGE); - paddingPtr->top = paddingPtr->bottom = GetSystemMetrics(SM_CYEDGE); + paddingPtr->left = paddingPtr->right = (short)GetSystemMetrics(SM_CXEDGE); + paddingPtr->top = paddingPtr->bottom = (short)GetSystemMetrics(SM_CYEDGE); } static void ClientElementDraw( @@ -961,23 +962,23 @@ TtkWinTheme_Init( return TCL_ERROR; } - Ttk_RegisterElementSpec(themePtr, "border", &BorderElementSpec, NULL); - Ttk_RegisterElementSpec(themePtr, "Button.border", + Ttk_RegisterElement(NULL, themePtr, "border", &BorderElementSpec, NULL); + Ttk_RegisterElement(NULL, themePtr, "Button.border", &ButtonBorderElementSpec, NULL); - Ttk_RegisterElementSpec(themePtr, "field", &FieldElementSpec, NULL); - Ttk_RegisterElementSpec(themePtr, "focus", &FocusElementSpec, NULL); - Ttk_RegisterElementSpec(themePtr, "Combobox.focus", + Ttk_RegisterElement(NULL, themePtr, "field", &FieldElementSpec, NULL); + Ttk_RegisterElement(NULL, themePtr, "focus", &FocusElementSpec, NULL); + Ttk_RegisterElement(NULL, themePtr, "Combobox.focus", &ComboboxFocusElementSpec, NULL); - Ttk_RegisterElementSpec(themePtr, "thumb", &ThumbElementSpec, NULL); - Ttk_RegisterElementSpec(themePtr, "slider", &SliderElementSpec, NULL); - Ttk_RegisterElementSpec(themePtr, "Scrollbar.trough", &TroughElementSpec, + Ttk_RegisterElement(NULL, themePtr, "thumb", &ThumbElementSpec, NULL); + Ttk_RegisterElement(NULL, themePtr, "slider", &SliderElementSpec, NULL); + Ttk_RegisterElement(NULL, themePtr, "Scrollbar.trough", &TroughElementSpec, TroughClientDataInit(interp)); - Ttk_RegisterElementSpec(themePtr, "tab", &TabElementSpec, NULL); - Ttk_RegisterElementSpec(themePtr, "client", &ClientElementSpec, NULL); + Ttk_RegisterElement(NULL, themePtr, "tab", &TabElementSpec, NULL); + Ttk_RegisterElement(NULL, themePtr, "client", &ClientElementSpec, NULL); for (fce = FrameControlElements; fce->name != 0; ++fce) { - Ttk_RegisterElementSpec(themePtr, fce->name, + Ttk_RegisterElement(NULL, themePtr, fce->name, &FrameControlElementSpec, (void *)fce); } diff --git a/win/ttkWinXPTheme.c b/win/ttkWinVistaTheme.c index 8fd1f58..d71374d 100644 --- a/win/ttkWinXPTheme.c +++ b/win/ttkWinVistaTheme.c @@ -1,5 +1,5 @@ /* - * Tk theme engine which uses the Windows XP "Visual Styles" API + * Tk theme engine which uses the Windows "Visual Styles" API * Adapted from Georgios Petasis' XP theme patch. * * Copyright © 2003 Georgios Petasis, petasis@iit.demokritos.gr. @@ -20,129 +20,29 @@ #include <uxtheme.h> #include <vssym32.h> #include "ttk/ttkThemeInt.h" - -typedef HTHEME (STDAPICALLTYPE OpenThemeDataProc)(HWND hwnd, - LPCWSTR pszClassList); -typedef HRESULT (STDAPICALLTYPE CloseThemeDataProc)(HTHEME hTheme); -typedef HRESULT (STDAPICALLTYPE DrawThemeBackgroundProc)(HTHEME hTheme, - HDC hdc, int iPartId, int iStateId, const RECT *pRect, - OPTIONAL const RECT *pClipRect); -typedef HRESULT (STDAPICALLTYPE DrawThemeEdgeProc)(HTHEME hTheme, - HDC hdc, int iPartId, int iStateId, const RECT *pDestRect, - unsigned int uEdge, unsigned int uFlags, - OPTIONAL RECT *pContentRect); -typedef HRESULT (STDAPICALLTYPE GetThemePartSizeProc)(HTHEME,HDC, - int iPartId, int iStateId, - RECT *prc, enum THEMESIZE eSize, SIZE *psz); -typedef int (STDAPICALLTYPE GetThemeSysSizeProc)(HTHEME,int); -/* GetThemeTextExtent and DrawThemeText only used with BROKEN_TEXT_ELEMENT */ -typedef HRESULT (STDAPICALLTYPE GetThemeTextExtentProc)(HTHEME hTheme, HDC hdc, - int iPartId, int iStateId, LPCWSTR pszText, int iCharCount, - DWORD dwTextFlags, const RECT *pBoundingRect, RECT *pExtent); -typedef HRESULT (STDAPICALLTYPE DrawThemeTextProc)(HTHEME hTheme, HDC hdc, - int iPartId, int iStateId, LPCWSTR pszText, int iCharCount, - DWORD dwTextFlags, DWORD dwTextFlags2, const RECT *pRect); -typedef BOOL (STDAPICALLTYPE IsThemeActiveProc)(void); -typedef BOOL (STDAPICALLTYPE IsAppThemedProc)(void); - -typedef struct -{ - OpenThemeDataProc *OpenThemeData; - CloseThemeDataProc *CloseThemeData; - GetThemePartSizeProc *GetThemePartSize; - GetThemeSysSizeProc *GetThemeSysSize; - DrawThemeBackgroundProc *DrawThemeBackground; - DrawThemeEdgeProc *DrawThemeEdge; - DrawThemeTextProc *DrawThemeText; - GetThemeTextExtentProc *GetThemeTextExtent; - IsThemeActiveProc *IsThemeActive; - IsAppThemedProc *IsAppThemed; - - HWND stubWindow; -} XPThemeProcs; - -typedef struct -{ - HINSTANCE hlibrary; - XPThemeProcs *procs; -} XPThemeData; - -/* - *---------------------------------------------------------------------- - * - * LoadXPThemeProcs -- - * Initialize XP theming support. - * - * XP theme support is included in UXTHEME.DLL - * We dynamically load this DLL at runtime instead of linking - * to it at build-time. - * - * Returns: - * A pointer to an XPThemeProcs table if successful, NULL otherwise. - */ - -static XPThemeProcs * -LoadXPThemeProcs(HINSTANCE *phlib) -{ - /* - * Load the library "uxtheme.dll", where the native widget - * drawing routines are implemented. This will only succeed - * if we are running at least on Windows XP. - */ - HINSTANCE handle; - *phlib = handle = LoadLibraryW(L"uxtheme.dll"); - if (handle != 0) - { - /* - * We have successfully loaded the library. Proceed in storing the - * addresses of the functions we want to use. - */ - XPThemeProcs *procs = (XPThemeProcs *)ckalloc(sizeof(XPThemeProcs)); -#define LOADPROC(name) \ - (0 != (procs->name = (name ## Proc *)(void *)GetProcAddress(handle, #name) )) - - if ( LOADPROC(OpenThemeData) - && LOADPROC(CloseThemeData) - && LOADPROC(GetThemePartSize) - && LOADPROC(GetThemeSysSize) - && LOADPROC(DrawThemeBackground) - && LOADPROC(DrawThemeEdge) - && LOADPROC(GetThemeTextExtent) - && LOADPROC(DrawThemeText) - && LOADPROC(IsThemeActive) - && LOADPROC(IsAppThemed) - ) - { - return procs; - } -#undef LOADPROC - ckfree(procs); - } - return 0; -} +#ifdef _MSC_VER +# pragma comment (lib, "uxtheme.lib") +#endif /* - * XPThemeDeleteProc -- + * VistaThemeDeleteProc -- * * Release any theme allocated resources. */ static void -XPThemeDeleteProc(void *clientData) +VistaThemeDeleteProc( + TCL_UNUSED(void *)) { - XPThemeData *themeData = (XPThemeData *)clientData; - FreeLibrary(themeData->hlibrary); - ckfree(clientData); } static int -XPThemeEnabled( +VistaThemeEnabled( TCL_UNUSED(Ttk_Theme), - void *clientData) + TCL_UNUSED(void *)) { - XPThemeData *themeData = (XPThemeData *)clientData; - int active = themeData->procs->IsThemeActive(); - int themed = themeData->procs->IsAppThemed(); + int active = IsThemeActive(); + int themed = IsAppThemed(); return (active && themed); } @@ -163,7 +63,7 @@ BoxToRect(Ttk_Box b) } /* - * Map Tk state bitmaps to XP style enumerated values. + * Map Tk state bitmaps to Vista style enumerated values. */ static const Ttk_StateTable null_statemap[] = { {0,0,0} }; @@ -352,7 +252,7 @@ static const Ttk_StateTable tabitem_statemap[] = * * The following structure is passed as the 'clientData' pointer * to most elements in this theme. It contains data relevant - * to a single XP Theme "part". + * to a single Vista Theme "part". * * <<NOTE-GetThemeMargins>>: * In theory, we should be call GetThemeMargins(...TMT_CONTENTRECT...) @@ -368,14 +268,14 @@ static const Ttk_StateTable tabitem_statemap[] = * BP_PUSHBUTTONS). Set the IGNORE_THEMESIZE flag to skip this call. */ -typedef struct /* XP element specifications */ +typedef struct /* Vista element specifications */ { const char *elementName; /* Tk theme engine element name */ const Ttk_ElementSpec *elementSpec; /* Element spec (usually GenericElementSpec) */ LPCWSTR className; /* Windows window class name */ int partId; /* BP_PUSHBUTTON, BP_CHECKBUTTON, etc. */ - const Ttk_StateTable *statemap; /* Map Tk states to XP states */ + const Ttk_StateTable *statemap; /* Map Tk states to Vista states */ Ttk_Padding padding; /* See NOTE-GetThemeMargins */ unsigned flags; # define IGNORE_THEMESIZE 0x80000000U /* See NOTE-GetThemePartSize */ @@ -391,7 +291,7 @@ typedef struct * Static data, initialized when element is registered: */ const ElementInfo *info; - XPThemeProcs *procs; /* Pointer to theme procedure table */ + HWND parentHwnd; /* * Dynamic data, allocated by InitElementData: @@ -406,11 +306,11 @@ typedef struct } ElementData; static ElementData * -NewElementData(XPThemeProcs *procs, const ElementInfo *info) +NewElementData(HWND hwnd, const ElementInfo *info) { - ElementData *elementData = (ElementData *)ckalloc(sizeof(ElementData)); + ElementData *elementData = (ElementData *)Tcl_Alloc(sizeof(ElementData)); - elementData->procs = procs; + elementData->parentHwnd = hwnd; elementData->info = info; elementData->hTheme = elementData->hDC = 0; @@ -426,12 +326,12 @@ static void DestroyElementData(void *clientData) { ElementData *elementData = (ElementData *)clientData; if (elementData->info->flags & HEAP_ELEMENT) { - ckfree((void *)elementData->info->statemap); - ckfree((void *)elementData->info->className); - ckfree((void *)elementData->info->elementName); - ckfree((void *)elementData->info); + Tcl_Free((void *)elementData->info->statemap); + Tcl_Free((void *)elementData->info->className); + Tcl_Free((void *)elementData->info->elementName); + Tcl_Free((void *)elementData->info); } - ckfree(clientData); + Tcl_Free(clientData); } /* @@ -453,19 +353,20 @@ InitElementData(ElementData *elementData, Tk_Window tkwin, Drawable d) if (win) { elementData->hwnd = Tk_GetHWND(win); } else { - elementData->hwnd = elementData->procs->stubWindow; + elementData->hwnd = elementData->parentHwnd; } - elementData->hTheme = elementData->procs->OpenThemeData( - elementData->hwnd, elementData->info->className); + elementData->hTheme = OpenThemeData( + elementData->hwnd, elementData->info->className); - if (!elementData->hTheme) + if (!elementData->hTheme) { return 0; + } elementData->drawable = d; if (d != 0) { elementData->hDC = TkWinGetDrawableDC(Tk_Display(tkwin), d, - &elementData->dcState); + &elementData->dcState); } return 1; @@ -474,7 +375,7 @@ InitElementData(ElementData *elementData, Tk_Window tkwin, Drawable d) static void FreeElementData(ElementData *elementData) { - elementData->procs->CloseThemeData(elementData->hTheme); + CloseThemeData(elementData->hTheme); if (elementData->drawable != 0) { TkWinReleaseDrawableDC( elementData->drawable, elementData->hDC, &elementData->dcState); @@ -484,7 +385,7 @@ FreeElementData(ElementData *elementData) /*---------------------------------------------------------------------- * +++ Generic element implementation. * - * Used for elements which are handled entirely by the XP Theme API, + * Used for elements which are handled entirely by the Vista Theme API, * such as radiobutton and checkbutton indicators, scrollbar arrows, etc. */ @@ -500,11 +401,12 @@ static void GenericElementSize( HRESULT result; SIZE size; - if (!InitElementData(elementData, tkwin, 0)) + if (!InitElementData(elementData, tkwin, 0)) { return; + } if (!(elementData->info->flags & IGNORE_THEMESIZE)) { - result = elementData->procs->GetThemePartSize( + result = GetThemePartSize( elementData->hTheme, NULL, elementData->info->partId, @@ -548,7 +450,7 @@ static void GenericElementDraw( } rc = BoxToRect(b); - elementData->procs->DrawThemeBackground( + DrawThemeBackground( elementData->hTheme, elementData->hDC, elementData->info->partId, @@ -571,7 +473,7 @@ static const Ttk_ElementSpec GenericElementSpec = /*---------------------------------------------------------------------- * +++ Sized element implementation. * - * Used for elements which are handled entirely by the XP Theme API, + * Used for elements which are handled entirely by the Vista Theme API, * but that require a fixed size adjustment. * Note that GetThemeSysSize calls through to GetSystemMetrics */ @@ -583,20 +485,23 @@ GenericSizedElementSize( { ElementData *elementData = (ElementData *)clientData; - if (!InitElementData(elementData, tkwin, 0)) + if (!InitElementData(elementData, tkwin, 0)) { return; + } GenericElementSize(clientData, elementRecord, tkwin, widthPtr, heightPtr, paddingPtr); - *widthPtr = elementData->procs->GetThemeSysSize(NULL, + *widthPtr = GetThemeSysSize(NULL, (elementData->info->flags >> 8) & 0xff); - *heightPtr = elementData->procs->GetThemeSysSize(NULL, + *heightPtr = GetThemeSysSize(NULL, elementData->info->flags & 0xff); - if (elementData->info->flags & HALF_HEIGHT) + if (elementData->info->flags & HALF_HEIGHT) { *heightPtr /= 2; - if (elementData->info->flags & HALF_WIDTH) + } + if (elementData->info->flags & HALF_WIDTH) { *widthPtr /= 2; + } } static const Ttk_ElementSpec GenericSizedElementSpec = { @@ -619,8 +524,9 @@ SpinboxArrowElementSize( { ElementData *elementData = (ElementData *)clientData; - if (!InitElementData(elementData, tkwin, 0)) + if (!InitElementData(elementData, tkwin, 0)) { return; + } GenericSizedElementSize(clientData, elementRecord, tkwin, widthPtr, heightPtr, paddingPtr); @@ -651,19 +557,21 @@ static void ThumbElementDraw( Ttk_State state) { ElementData *elementData = (ElementData *)clientData; - unsigned stateId = Ttk_StateTableLookup(elementData->info->statemap, state); + int stateId = Ttk_StateTableLookup(elementData->info->statemap, state); RECT rc = BoxToRect(b); /* * Don't draw the thumb if we are disabled. */ - if (state & TTK_STATE_DISABLED) + if (state & TTK_STATE_DISABLED) { return; + } - if (!InitElementData(elementData, tkwin, d)) + if (!InitElementData(elementData, tkwin, d)) { return; + } - elementData->procs->DrawThemeBackground(elementData->hTheme, + DrawThemeBackground(elementData->hTheme, elementData->hDC, elementData->info->partId, stateId, &rc, NULL); @@ -801,8 +709,9 @@ static void TabElementDraw( RECT rc = BoxToRect(b); - if (!InitElementData(elementData, tkwin, d)) + if (!InitElementData(elementData, tkwin, d)) { return; + } if (nbTabsStickBit == TTK_STICK_S) { if (state & TTK_STATE_FIRST) { @@ -812,7 +721,7 @@ static void TabElementDraw( /* * Draw the border and fill into rc */ - elementData->procs->DrawThemeBackground( + DrawThemeBackground( elementData->hTheme, elementData->hDC, partId, stateId, &rc, NULL); } else { /* @@ -820,7 +729,7 @@ static void TabElementDraw( */ RECT rc2 = rc; --rc2.top; --rc2.left; ++rc2.bottom; ++rc2.right; - elementData->procs->DrawThemeBackground( + DrawThemeBackground( elementData->hTheme, elementData->hDC, partId, stateId, &rc2, &rc); } @@ -832,17 +741,17 @@ static void TabElementDraw( case TTK_STICK_S: break; case TTK_STICK_N: - elementData->procs->DrawThemeEdge( + DrawThemeEdge( elementData->hTheme, elementData->hDC, partId, stateId, &rc, BDR_RAISEDINNER, BF_FLAT|BF_LEFT|BF_RIGHT|BF_BOTTOM, NULL); break; case TTK_STICK_E: - elementData->procs->DrawThemeEdge( + DrawThemeEdge( elementData->hTheme, elementData->hDC, partId, stateId, &rc, BDR_RAISEDINNER, BF_FLAT|BF_LEFT|BF_TOP|BF_BOTTOM, NULL); break; case TTK_STICK_W: - elementData->procs->DrawThemeEdge( + DrawThemeEdge( elementData->hTheme, elementData->hDC, partId, stateId, &rc, BDR_RAISEDINNER, BF_FLAT|BF_TOP|BF_RIGHT|BF_BOTTOM, NULL); break; @@ -905,116 +814,6 @@ static const Ttk_ElementSpec TreeIndicatorElementSpec = TreeIndicatorElementDraw }; -#ifdef BROKEN_TEXT_ELEMENT - -/* - *---------------------------------------------------------------------- - * Text element (does not work yet). - * - * According to "Using Windows XP Visual Styles", we need to select - * a font into the DC before calling DrawThemeText(). - * There's just no easy way to get an HFONT out of a Tk_Font. - * Maybe GetThemeFont() would work? - * - */ - -typedef struct -{ - Tcl_Obj *textObj; - Tcl_Obj *fontObj; -} TextElement; - -static const Ttk_ElementOptionSpec TextElementOptions[] = -{ - { "-text", TK_OPTION_STRING, - offsetof(TextElement,textObj), "" }, - { "-font", TK_OPTION_FONT, - offsetof(TextElement,fontObj), DEFAULT_FONT }, - { NULL } -}; - -static void TextElementSize( - void *clientData, void *elementRecord, Tk_Window tkwin, - int *widthPtr, int *heightPtr, Ttk_Padding *paddingPtr) -{ - TextElement *element = elementRecord; - ElementData *elementData = clientData; - RECT rc = {0, 0}; - HRESULT hr = S_OK; - const char *src; - Tcl_Size len; - Tcl_DString ds; - - if (!InitElementData(elementData, tkwin, 0)) - return; - - src = Tcl_GetStringFromObj(element->textObj, &len); - Tcl_DStringInit(&ds); - hr = elementData->procs->GetThemeTextExtent( - elementData->hTheme, - elementData->hDC, - elementData->info->partId, - Ttk_StateTableLookup(elementData->info->statemap, 0), - Tcl_UtfToWCharDString(src, len, &ds), - -1, - DT_LEFT /* | DT_BOTTOM | DT_NOPREFIX */, - NULL, - &rc); - - if (SUCCEEDED(hr)) { - *widthPtr = rc.right - rc.left; - *heightPtr = rc.bottom - rc.top; - } - if (*widthPtr < 80) *widthPtr = 80; - if (*heightPtr < 20) *heightPtr = 20; - - Tcl_DStringFree(&ds); - FreeElementData(elementData); -} - -static void TextElementDraw( - void *clientData, void *elementRecord, Tk_Window tkwin, - Drawable d, Ttk_Box b, Ttk_State state) -{ - TextElement *element = elementRecord; - ElementData *elementData = clientData; - RECT rc = BoxToRect(b); - HRESULT hr = S_OK; - const char *src; - Tcl_Size len; - Tcl_DString ds; - - if (!InitElementData(elementData, tkwin, d)) - return; - - src = Tcl_GetStringFromObj(element->textObj, &len); - Tcl_DStringInit(&ds); - hr = elementData->procs->DrawThemeText( - elementData->hTheme, - elementData->hDC, - elementData->info->partId, - Ttk_StateTableLookup(elementData->info->statemap, state), - Tcl_UtfToWCharDString(src, len, &ds), - -1, - DT_LEFT /* | DT_BOTTOM | DT_NOPREFIX */, - (state & TTK_STATE_DISABLED) ? DTT_GRAYED : 0, - &rc); - - Tcl_DStringFree(&ds); - FreeElementData(elementData); -} - -static const Ttk_ElementSpec TextElementSpec = -{ - TK_STYLE_VERSION_2, - sizeof(TextElement), - TextElementOptions, - TextElementSize, - TextElementDraw -}; - -#endif /* BROKEN_TEXT_ELEMENT */ - /*---------------------------------------------------------------------- * +++ Widget layouts: */ @@ -1062,7 +861,7 @@ TTK_LAYOUT("Vertical.TScale", TTK_END_LAYOUT_TABLE /*---------------------------------------------------------------------- - * +++ XP element info table: + * +++ Vista element info table: */ #define PAD(l,t,r,b) {l,t,r,b} @@ -1157,10 +956,6 @@ static const ElementInfo ElementInfoTable[] = { { "Spinbox.downarrow", &SpinboxArrowElementSpec, L"SPIN", SPNP_DOWN, spinbutton_statemap, NOPAD, PAD_MARGINS | ((SM_CXVSCROLL << 8) | SM_CYVSCROLL) }, -#ifdef BROKEN_TEXT_ELEMENT - { "Labelframe.text", &TextElementSpec, L"BUTTON", - BP_GROUPBOX, groupbox_statemap, NOPAD, 0 }, -#endif { 0, 0, 0, 0, 0, NOPAD, 0 } }; #undef PAD @@ -1185,11 +980,12 @@ GetSysFlagFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *resultPtr) Tcl_Obj **objv; Tcl_Size i, objc; - if (Tcl_ListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) + if (Tcl_ListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) { return TCL_ERROR; + } if (objc != 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj("wrong # args", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); + Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", (char *)NULL); return TCL_ERROR; } for (i = 0; i < objc; ++i) { @@ -1223,14 +1019,14 @@ Ttk_CreateVsapiElement( Tcl_Size objc, Tcl_Obj *const objv[]) { - XPThemeData *themeData = (XPThemeData *)clientData; + HWND hwnd = (HWND)clientData; ElementInfo *elementPtr = NULL; void *elementData; LPCWSTR className; int partId = 0; Ttk_StateTable *stateTable; Ttk_Padding pad = {0, 0, 0, 0}; - int flags = 0; + unsigned flags = 0; Tcl_Size length = 0; char *name; LPWSTR wname; @@ -1246,7 +1042,7 @@ Ttk_CreateVsapiElement( if (objc < 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing required arguments 'class' and/or 'partId'", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TTK", "VSAPI", "REQUIRED", NULL); + Tcl_SetErrorCode(interp, "TTK", "VSAPI", "REQUIRED", (char *)NULL); return TCL_ERROR; } @@ -1267,7 +1063,7 @@ Ttk_CreateVsapiElement( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "Missing value for \"%s\".", Tcl_GetString(objv[i]))); - Tcl_SetErrorCode(interp, "TTK", "VSAPI", "MISSING", NULL); + Tcl_SetErrorCode(interp, "TTK", "VSAPI", "MISSING", (char *)NULL); goto retErr; } if (Tcl_GetIndexFromObj(interp, objv[i], optionStrings, @@ -1289,14 +1085,14 @@ Ttk_CreateVsapiElement( if (Tcl_GetIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) { goto retErr; } - pad.left = pad.right = tmp; + pad.left = pad.right = (short)tmp; flags |= IGNORE_THEMESIZE; break; case O_HEIGHT: if (Tcl_GetIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) { goto retErr; } - pad.top = pad.bottom = tmp; + pad.top = pad.bottom = (short)tmp; flags |= IGNORE_THEMESIZE; break; case O_SYSSIZE: @@ -1310,15 +1106,17 @@ Ttk_CreateVsapiElement( if (Tcl_GetBooleanFromObj(interp, objv[i+1], &tmp) != TCL_OK) { goto retErr; } - if (tmp) + if (tmp) { flags |= HALF_HEIGHT; + } break; case O_HALFWIDTH: if (Tcl_GetBooleanFromObj(interp, objv[i+1], &tmp) != TCL_OK) { goto retErr; } - if (tmp) + if (tmp) { flags |= HALF_WIDTH; + } break; } } @@ -1329,11 +1127,12 @@ Ttk_CreateVsapiElement( Tcl_Obj **specs; Tcl_Size n, j, count; int status = TCL_OK; - if (Tcl_ListObjGetElements(interp, objv[2], &count, &specs) != TCL_OK) + if (Tcl_ListObjGetElements(interp, objv[2], &count, &specs) != TCL_OK) { goto retErr; + } /* we over-allocate to ensure there is a terminating entry */ - stateTable = (Ttk_StateTable *)ckalloc(sizeof(Ttk_StateTable) * (count + 1)); - memset(stateTable, 0, sizeof(Ttk_StateTable) * (count + 1)); + stateTable = (Ttk_StateTable *)Tcl_Alloc(sizeof(Ttk_StateTable) * ((size_t)count + 1)); + memset(stateTable, 0, sizeof(Ttk_StateTable) * ((size_t)count + 1)); for (n = 0, j = 0; status == TCL_OK && n < count; n += 2, ++j) { Ttk_StateSpec spec = {0,0}; status = Ttk_GetStateSpecFromObj(interp, specs[n], &spec); @@ -1345,34 +1144,34 @@ Ttk_CreateVsapiElement( } } if (status != TCL_OK) { - ckfree(stateTable); + Tcl_Free(stateTable); Tcl_DStringFree(&classBuf); return status; } } else { - stateTable = (Ttk_StateTable *)ckalloc(sizeof(Ttk_StateTable)); + stateTable = (Ttk_StateTable *)Tcl_Alloc(sizeof(Ttk_StateTable)); memset(stateTable, 0, sizeof(Ttk_StateTable)); } - elementPtr = (ElementInfo *)ckalloc(sizeof(ElementInfo)); + elementPtr = (ElementInfo *)Tcl_Alloc(sizeof(ElementInfo)); elementPtr->elementSpec = elementSpec; elementPtr->partId = partId; elementPtr->statemap = stateTable; elementPtr->padding = pad; - elementPtr->flags = HEAP_ELEMENT | flags; + elementPtr->flags = HEAP_ELEMENT | (unsigned)flags; /* set the element name to an allocated copy */ - name = (char *)ckalloc(strlen(elementName) + 1); + name = (char *)Tcl_Alloc(strlen(elementName) + 1); strcpy(name, elementName); elementPtr->elementName = name; /* set the class name to an allocated copy */ - wname = (LPWSTR)ckalloc(Tcl_DStringLength(&classBuf) + sizeof(WCHAR)); + wname = (LPWSTR)Tcl_Alloc((size_t)Tcl_DStringLength(&classBuf) + sizeof(WCHAR)); wcscpy(wname, className); elementPtr->className = wname; - elementData = NewElementData(themeData->procs, elementPtr); - Ttk_RegisterElementSpec( + elementData = NewElementData(hwnd, elementPtr); + Ttk_RegisterElement(NULL, theme, elementName, elementPtr->elementSpec, elementData); Ttk_RegisterCleanup(interp, elementData, DestroyElementData); @@ -1390,70 +1189,47 @@ retErr: */ MODULE_SCOPE int -TtkXPTheme_Init(Tcl_Interp *interp, HWND hwnd) +TtkWinVistaTheme_Init(Tcl_Interp *interp, HWND hwnd) { - XPThemeData *themeData; - XPThemeProcs *procs; - HINSTANCE hlibrary; - Ttk_Theme themePtr, parentPtr, vistaPtr; + Ttk_Theme themePtr, parentPtr; const ElementInfo *infoPtr; - procs = LoadXPThemeProcs(&hlibrary); - if (!procs) - return TCL_ERROR; - procs->stubWindow = hwnd; - /* * Create the new style engine. */ parentPtr = Ttk_GetTheme(interp, "winnative"); - themePtr = Ttk_CreateTheme(interp, "xpnative", parentPtr); + themePtr = Ttk_CreateTheme(interp, "vista", parentPtr); - if (!themePtr) + if (!themePtr) { return TCL_ERROR; + } /* * Set theme data and cleanup proc */ - themeData = (XPThemeData *)ckalloc(sizeof(XPThemeData)); - themeData->procs = procs; - themeData->hlibrary = hlibrary; - - Ttk_SetThemeEnabledProc(themePtr, XPThemeEnabled, themeData); - Ttk_RegisterCleanup(interp, themeData, XPThemeDeleteProc); - Ttk_RegisterElementFactory(interp, "vsapi", Ttk_CreateVsapiElement, themeData); - - /* - * Create the vista theme on suitable platform versions and set the theme - * enable function. The theme itself is defined in script. - */ - - if (TkWinGetPlatformTheme() == TK_THEME_WIN_VISTA) { - vistaPtr = Ttk_CreateTheme(interp, "vista", themePtr); - if (vistaPtr) { - Ttk_SetThemeEnabledProc(vistaPtr, XPThemeEnabled, themeData); - } - } + Ttk_SetThemeEnabledProc(themePtr, VistaThemeEnabled, hwnd); + Ttk_RegisterCleanup(interp, hwnd, VistaThemeDeleteProc); + Ttk_RegisterElementFactory(interp, "vsapi", Ttk_CreateVsapiElement, hwnd); /* * New elements: */ for (infoPtr = ElementInfoTable; infoPtr->elementName != 0; ++infoPtr) { - void *clientData = NewElementData(procs, infoPtr); - Ttk_RegisterElementSpec( + void *clientData = NewElementData(hwnd, infoPtr); + Ttk_RegisterElement(NULL, themePtr, infoPtr->elementName, infoPtr->elementSpec, clientData); Ttk_RegisterCleanup(interp, clientData, DestroyElementData); } - Ttk_RegisterElementSpec(themePtr, "Scale.trough", &ttkNullElementSpec, 0); + Ttk_RegisterElement(NULL, themePtr, "Scale.trough", &ttkNullElementSpec, 0); /* * Layouts: */ Ttk_RegisterLayouts(themePtr, LayoutTable); - Tcl_PkgProvide(interp, "ttk::theme::xpnative", TTK_VERSION); + Tcl_PkgProvide(interp, "ttk::theme::vista", TTK_VERSION); return TCL_OK; } diff --git a/win/winMain.c b/win/winMain.c index e77e8dd..b431a4c 100644 --- a/win/winMain.c +++ b/win/winMain.c @@ -72,9 +72,6 @@ extern Tcl_LibraryInitProc Dde_SafeInit; #ifdef __cplusplus } #endif -#ifdef TCL_BROKEN_MAINARGS -static void setargv(int *argcPtr, TCHAR ***argvPtr); -#endif /* * Forward declarations for procedures defined later in this file: @@ -131,19 +128,11 @@ MODULE_SCOPE int TK_LOCAL_MAIN_HOOK(int *argc, TCHAR ***argv); */ int APIENTRY -#ifdef TCL_BROKEN_MAINARGS -WinMain( - HINSTANCE hInstance, - HINSTANCE hPrevInstance, - LPSTR lpszCmdLine, - int nCmdShow) -#else _tWinMain( HINSTANCE hInstance, HINSTANCE hPrevInstance, LPTSTR lpszCmdLine, int nCmdShow) -#endif { TCHAR **argv; int argc; @@ -172,12 +161,8 @@ _tWinMain( * Get our args from the c-runtime. Ignore lpszCmdLine. */ -#if defined(TCL_BROKEN_MAINARGS) - setargv(&argc, &argv); -#else argc = __argc; argv = __targv; -#endif /* * Forward slashes substituted for backslashes. @@ -307,21 +292,11 @@ Tcl_AppInit( *---------------------------------------------------------------------- */ -#ifdef TCL_BROKEN_MAINARGS -int -main( - int argc, - char **dummy) -{ - TCHAR **argv; - (void)dummy; -#else int _tmain( int argc, TCHAR **argv) { -#endif /* * Set up the default locale to be standard "C" locale so parsing is * performed correctly. @@ -329,13 +304,6 @@ _tmain( setlocale(LC_ALL, "C"); -#ifdef TCL_BROKEN_MAINARGS - /* - * Get our args from the c-runtime. Ignore argc/argv. - */ - - setargv(&argc, &argv); -#endif /* * Console emulation widget not required as this entry is from the * console subsystem, thus stdin,out,err already have end-points. @@ -351,131 +319,6 @@ _tmain( return 0; } #endif /* !__GNUC__ || TK_TEST */ - - -/* - *------------------------------------------------------------------------- - * - * setargv -- - * - * Parse the Windows command line string into argc/argv. Done here - * because we don't trust the builtin argument parser in crt0. Windows - * applications are responsible for breaking their command line into - * arguments. - * - * 2N backslashes + quote -> N backslashes + begin quoted string - * 2N + 1 backslashes + quote -> literal - * N backslashes + non-quote -> literal - * quote + quote in a quoted string -> single quote - * quote + quote not in quoted string -> empty string - * quote -> begin quoted string - * - * Results: - * Fills argcPtr with the number of arguments and argvPtr with the array - * of arguments. - * - * Side effects: - * Memory allocated. - * - *-------------------------------------------------------------------------- - */ - -#ifdef TCL_BROKEN_MAINARGS -static void -setargv( - int *argcPtr, /* Filled with number of argument strings. */ - TCHAR ***argvPtr) /* Filled with argument strings (malloc'd). */ -{ - TCHAR *cmdLine, *p, *arg, *argSpace; - TCHAR **argv; - int argc, size, inquote, copy, slashes; - - cmdLine = GetCommandLine(); - - /* - * Precompute an overly pessimistic guess at the number of arguments in - * the command line by counting non-space spans. - */ - - size = 2; - for (p = cmdLine; *p != '\0'; p++) { - if ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */ - size++; - while ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */ - p++; - } - if (*p == '\0') { - break; - } - } - } - - /* Make sure we don't call ckalloc through the (not yet initialized) stub table */ - #undef Tcl_Alloc - #undef Tcl_DbCkalloc - - argSpace = (TCHAR *)ckalloc(size * sizeof(char *) - + (_tcslen(cmdLine) * sizeof(TCHAR)) + sizeof(TCHAR)); - argv = (TCHAR **) argSpace; - argSpace += size * (sizeof(char *)/sizeof(TCHAR)); - size--; - - p = cmdLine; - for (argc = 0; argc < size; argc++) { - argv[argc] = arg = argSpace; - while ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */ - p++; - } - if (*p == '\0') { - break; - } - - inquote = 0; - slashes = 0; - while (1) { - copy = 1; - while (*p == '\\') { - slashes++; - p++; - } - if (*p == '"') { - if ((slashes & 1) == 0) { - copy = 0; - if ((inquote) && (p[1] == '"')) { - p++; - copy = 1; - } else { - inquote = !inquote; - } - } - slashes >>= 1; - } - - while (slashes) { - *arg = '\\'; - arg++; - slashes--; - } - - if ((*p == '\0') || (!inquote && - ((*p == ' ') || (*p == '\t')))) { /* INTL: ISO space. */ - break; - } - if (copy != 0) { - *arg = *p; - arg++; - } - p++; - } - *arg = '\0'; - argSpace = arg + 1; - } - argv[argc] = NULL; - - *argcPtr = argc; - *argvPtr = argv; -} -#endif /* TCL_BROKEN_MAINARGS */ /* * Local Variables: diff --git a/win/wish.exe.manifest.in b/win/wish.exe.manifest.in index 20a79a4..9fefac9 100644 --- a/win/wish.exe.manifest.in +++ b/win/wish.exe.manifest.in @@ -35,10 +35,6 @@ xmlns="http://schemas.microsoft.com/SMI/2005/WindowsSettings"> <dpiAware>true</dpiAware> </asmv3:windowsSettings> - <asmv3:windowsSettings - xmlns="http://schemas.microsoft.com/SMI/2019/WindowsSettings"> - <activeCodePage>UTF-8</activeCodePage> - </asmv3:windowsSettings> </asmv3:application> <dependency> <dependentAssembly> diff --git a/xlib/X11/Xlib.h b/xlib/X11/Xlib.h index 9bdf149..4e7b445 100644 --- a/xlib/X11/Xlib.h +++ b/xlib/X11/Xlib.h @@ -4024,7 +4024,7 @@ EXTERN void XFreeEventData( XGenericEventCookie* /* cookie*/ ); -#include "tkIntXlibDecls.h" +#include "tkIntXlibDecls.h" /* IWYU pragma: export */ #ifdef __clang__ #pragma clang diagnostic pop diff --git a/xlib/xcolors.c b/xlib/xcolors.c index 03aefce..68911d4 100644 --- a/xlib/xcolors.c +++ b/xlib/xcolors.c @@ -40,194 +40,345 @@ static const unsigned char az[] = { * are handled by this table, above that is handled especially. */ -typedef char elem[32]; +typedef unsigned char elem[32]; static const elem xColors[] = { /* Colors starting with 'a' */ - "liceBlue\0 \360\370\377\0", - "ntiqueWhite\0 \213\203\170\315\300\260\356\337\314\377\357\333\372\353\327\4", - "qua\0 \000\377\377\0", - "quamarine\0 \105\213\164\146\315\252\166\356\306\177\377\324\177\377\324\4", - "zure\0 \203\213\213\301\315\315\340\356\356\360\377\377\360\377\377\4", + {'l', 'i', 'c', 'e', 'B', 'l', 'u', 'e', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0xF0, 0xF8, 0xFF, 0x00}, + {'n', 't', 'i', 'q', 'u', 'e', 'W', 'h', 'i', 't', 'e', 0, 0, 0, 0, 0, + 0x8B, 0x83, 0x78, 0xCD, 0xC0, 0xB0, 0xEE, 0xDF, 0xCC, 0xFF, 0xEF, 0xDB, 0xFA, 0xEB, 0xD7, 0x04}, + {'q', 'u', 'a', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x00, 0xFF, 0xFF, 0x00}, + {'q', 'u', 'a', 'm', 'a', 'r', 'i', 'n', 'e', 0, 0, 0, 0, 0, 0, 0, + 0x45, 0x8B, 0x74, 0x66, 0xCD, 0xAA, 0x76, 0xEE, 0xC6, 0x7F, 0xFF, 0xD4, 0x7F, 0xFF, 0xD4, 0x04}, + {'z', 'u', 'r', 'e', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x83, 0x8B, 0x8B, 0xC1, 0xCD, 0xCD, 0xE0, 0xEE, 0xEE, 0xF0, 0xFF, 0xFF, 0xF0, 0xFF, 0xFF, 0x04}, /* Colors starting with 'b' */ - "eige\0 \365\365\334\0", - "isque\0 \213\175\153\315\267\236\356\325\267\377\344\304\377\344\304\4", - "lack\0 \000\000\000\0", - "lanchedAlmond\0 \377\353\315\0", - "lue\0 \000\000\213\000\000\315\000\000\356\000\000\377\000\000\377\4", - "lueViolet\0 \212\053\342\0", - "rown\0 \213\043\043\315\063\063\356\073\073\377\100\100\245\052\052\4", - "urlywood\0 \213\163\125\315\252\175\356\305\221\377\323\233\336\270\207\4", + {'e', 'i', 'g', 'e', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0xF5, 0xF5, 0xDC, 0x00}, + {'i', 's', 'q', 'u', 'e', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x8B, 0x7D, 0x6B, 0xCD, 0xB7, 0x9E, 0xEE, 0xD5, 0xB7, 0xFF, 0xE4, 0xC4, 0xFF, 0xE4, 0xC4, 0x04}, + {'l', 'a', 'c', 'k', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x00, 0x00, 0x00, 0x00}, + {'l', 'a', 'n', 'c', 'h', 'e', 'd', 'A', 'l', 'm', 'o', 'n', 'd', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0xFF, 0xEB, 0xCD, 0x00}, + {'l', 'u', 'e', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x00, 0x00, 0x8B, 0x00, 0x00, 0xCD, 0x00, 0x00, 0xEE, 0x00, 0x00, 0xFF, 0x00, 0x00, 0xFF, 0x04}, + {'l', 'u', 'e', 'V', 'i', 'o', 'l', 'e', 't', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x8A, 0x2B, 0xE2, 0x00}, + {'r', 'o', 'w', 'n', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x8B, 0x23, 0x23, 0xCD, 0x33, 0x33, 0xEE, 0x3B, 0x3B, 0xFF, 0x40, 0x40, 0xA5, 0x2A, 0x2A, 0x04}, + {'u', 'r', 'l', 'y', 'w', 'o', 'o', 'd', 0, 0, 0, 0, 0, 0, 0, 0, + 0x8B, 0x73, 0x55, 0xCD, 0xAA, 0x7D, 0xEE, 0xC5, 0x91, 0xFF, 0xD3, 0x9B, 0xDE, 0xB8, 0x87, 0x04}, /* Colors starting with 'c' */ - "adetBlue\0 \123\206\213\172\305\315\216\345\356\230\365\377\137\236\240\4", - "hartreuse\0 \105\213\000\146\315\000\166\356\000\177\377\000\177\377\000\4", - "hocolate\0 \213\105\023\315\146\035\356\166\041\377\177\044\322\151\036\4", - "oral\0 \213\076\057\315\133\105\356\152\120\377\162\126\377\177\120\4", - "ornflowerBlue\0 \144\225\355\0", - "ornsilk\0 \213\210\170\315\310\261\356\350\315\377\370\334\377\370\334\4", - "rimson\0 \334\024\074\0", - "yan\0 \000\213\213\000\315\315\000\356\356\000\377\377\000\377\377\4", + {'a', 'd', 'e', 't', 'B', 'l', 'u', 'e', 0, 0, 0, 0, 0, 0, 0, 0, + 0x53, 0x86, 0x8B, 0x7A, 0xC5, 0xCD, 0x8E, 0xE5, 0xEE, 0x98, 0xF5, 0xFF, 0x5F, 0x9E, 0xA0, 0x04}, + {'h', 'a', 'r', 't', 'r', 'e', 'u', 's', 'e', 0, 0, 0, 0, 0, 0, 0, + 0x45, 0x8B, 0x00, 0x66, 0xCD, 0x00, 0x76, 0xEE, 0x00, 0x7F, 0xFF, 0x00, 0x7F, 0xFF, 0x00, 0x04}, + {'h', 'o', 'c', 'o', 'l', 'a', 't', 'e', 0, 0, 0, 0, 0, 0, 0, 0, + 0x8B, 0x45, 0x13, 0xCD, 0x66, 0x1D, 0xEE, 0x76, 0x21, 0xFF, 0x7F, 0x24, 0xD2, 0x69, 0x1E, 0x04}, + {'o', 'r', 'a', 'l', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x8B, 0x3E, 0x2F, 0xCD, 0x5B, 0x45, 0xEE, 0x6A, 0x50, 0xFF, 0x72, 0x56, 0xFF, 0x7F, 0x50, 0x04}, + {'o', 'r', 'n', 'f', 'l', 'o', 'w', 'e', 'r', 'B', 'l', 'u', 'e', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x64, 0x95, 0xED, 0x00}, + {'o', 'r', 'n', 's', 'i', 'l', 'k', 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x8B, 0x88, 0x78, 0xCD, 0xC8, 0xB1, 0xEE, 0xE8, 0xCD, 0xFF, 0xF8, 0xDC, 0xFF, 0xF8, 0xDC, 0x04}, + {'r', 'i', 'm', 's', 'o', 'n', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0xDC, 0x14, 0x3C, 0x00}, + {'y', 'a', 'n', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x00, 0x8B, 0x8B, 0x00, 0xCD, 0xCD, 0x00, 0xEE, 0xEE, 0x00, 0xFF, 0xFF, 0x00, 0xFF, 0xFF, 0x04}, /* Colors starting with 'd' */ - "arkBlue\0 \000\000\213\0", - "arkCyan\0 \000\213\213\0", - "arkGoldenrod\0 \213\145\010\315\225\014\356\255\016\377\271\017\270\206\013\4", - "arkGray\0 \251\251\251\0", - "arkGreen\0 \000\144\000\0", - "arkGrey\0 \251\251\251\0", - "arkKhaki\0 \275\267\153\0", - "arkMagenta\0 \213\000\213\0", - "arkOliveGreen\0 \156\213\075\242\315\132\274\356\150\312\377\160\125\153\057\4", - "arkOrange\0 \213\105\000\315\146\000\356\166\000\377\177\000\377\214\000\4", - "arkOrchid\0 \150\042\213\232\062\315\262\072\356\277\076\377\231\062\314\4", - "arkRed\0 \213\000\000\0", - "arkSalmon\0 \351\226\172\0", - "arkSeaGreen\0 \151\213\151\233\315\233\264\356\264\301\377\301\217\274\217\4", - "arkSlateBlue\0 \110\075\213\0", - "arkSlateGray\0 \122\213\213\171\315\315\215\356\356\227\377\377\057\117\117\4", - "arkSlateGrey\0 \057\117\117\0", - "arkTurquoise\0 \000\316\321\0", - "arkViolet\0 \224\000\323\0", - "eepPink\0 \213\012\120\315\020\166\356\022\211\377\024\223\377\024\223\4", - "eepSkyBlue\0 \000\150\213\000\232\315\000\262\356\000\277\377\000\277\377\4", - "imGray\0 \151\151\151\0", - "imGrey\0 \151\151\151\0", - "odgerBlue\0 \020\116\213\030\164\315\034\206\356\036\220\377\036\220\377\4", - /* Colors starting with 'e' */ - "\377 \0" /* placeholder */, + {'a', 'r', 'k', 'B', 'l', 'u', 'e', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x00, 0x00, 0x8B, 0x00}, + {'a', 'r', 'k', 'C', 'y', 'a', 'n', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x00, 0x8B, 0x8B, 0x00}, + {'a', 'r', 'k', 'G', 'o', 'l', 'd', 'e', 'n', 'r', 'o', 'd', 0, 0, 0, 0, + 0x8B, 0x65, 0x08, 0xCD, 0x95, 0x0C, 0xEE, 0xAD, 0x0E, 0xFF, 0xB9, 0x0F, 0xB8, 0x86, 0x0B, 0x04}, + {'a', 'r', 'k', 'G', 'r', 'a', 'y', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0xA9, 0xA9, 0xA9, 0x00}, + {'a', 'r', 'k', 'G', 'r', 'e', 'e', 'n', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x00, 0x64, 0x00, 0x00}, + {'a', 'r', 'k', 'G', 'r', 'e', 'y', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0xA9, 0xA9, 0xA9, 0x00}, + {'a', 'r', 'k', 'K', 'h', 'a', 'k', 'i', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0xBD, 0xB7, 0x6B, 0x00}, + {'a', 'r', 'k', 'M', 'a', 'g', 'e', 'n', 't', 'a', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x8B, 0x00, 0x8B, 0x00}, + {'a', 'r', 'k', 'O', 'l', 'i', 'v', 'e', 'G', 'r', 'e', 'e', 'n', 0, 0, 0, + 0x6E, 0x8B, 0x3D, 0xA2, 0xCD, 0x5A, 0xBC, 0xEE, 0x68, 0xCA, 0xFF, 0x70, 0x55, 0x6B, 0x2F, 0x04}, + {'a', 'r', 'k', 'O', 'r', 'a', 'n', 'g', 'e', 0, 0, 0, 0, 0, 0, 0, + 0x8B, 0x45, 0x00, 0xCD, 0x66, 0x00, 0xEE, 0x76, 0x00, 0xFF, 0x7F, 0x00, 0xFF, 0x8C, 0x00, 0x04}, + {'a', 'r', 'k', 'O', 'r', 'c', 'h', 'i', 'd', 0, 0, 0, 0, 0, 0, 0, + 0x68, 0x22, 0x8B, 0x9A, 0x32, 0xCD, 0xB2, 0x3A, 0xEE, 0xBF, 0x3E, 0xFF, 0x99, 0x32, 0xCC, 0x04}, + {'a', 'r', 'k', 'R', 'e', 'd', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x8B, 0x00, 0x00, 0x00}, + {'a', 'r', 'k', 'S', 'a', 'l', 'm', 'o', 'n', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0xE9, 0x96, 0x7A, 0x00}, + {'a', 'r', 'k', 'S', 'e', 'a', 'G', 'r', 'e', 'e', 'n', 0, 0, 0, 0, 0, + 0x69, 0x8B, 0x69, 0x9B, 0xCD, 0x9B, 0xB4, 0xEE, 0xB4, 0xC1, 0xFF, 0xC1, 0x8F, 0xBC, 0x8F, 0x04}, + {'a', 'r', 'k', 'S', 'l', 'a', 't', 'e', 'B', 'l', 'u', 'e', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x48, 0x3D, 0x8B, 0x00}, + {'a', 'r', 'k', 'S', 'l', 'a', 't', 'e', 'G', 'r', 'a', 'y', 0, 0, 0, 0, + 0x52, 0x8B, 0x8B, 0x79, 0xCD, 0xCD, 0x8D, 0xEE, 0xEE, 0x97, 0xFF, 0xFF, 0x2F, 0x4F, 0x4F, 0x04}, + {'a', 'r', 'k', 'S', 'l', 'a', 't', 'e', 'G', 'r', 'e', 'y', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x2F, 0x4F, 0x4F, 0x00}, + {'a', 'r', 'k', 'T', 'u', 'r', 'q', 'u', 'o', 'i', 's', 'e', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x00, 0xCE, 0xD1, 0x00}, + {'a', 'r', 'k', 'V', 'i', 'o', 'l', 'e', 't', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x94, 0x00, 0xD3, 0x00}, + {'e', 'e', 'p', 'P', 'i', 'n', 'k', 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x8B, 0x0A, 0x50, 0xCD, 0x10, 0x76, 0xEE, 0x12, 0x89, 0xFF, 0x14, 0x93, 0xFF, 0x14, 0x93, 0x04}, + {'e', 'e', 'p', 'S', 'k', 'y', 'B', 'l', 'u', 'e', 0, 0, 0, 0, 0, 0, + 0x00, 0x68, 0x8B, 0x00, 0x9A, 0xCD, 0x00, 0xB2, 0xEE, 0x00, 0xBF, 0xFF, 0x00, 0xBF, 0xFF, 0x04}, + {'i', 'm', 'G', 'r', 'a', 'y', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x69, 0x69, 0x69, 0x00}, + {'i', 'm', 'G', 'r', 'e', 'y', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x69, 0x69, 0x69, 0x00}, + {'o', 'd', 'g', 'e', 'r', 'B', 'l', 'u', 'e', 0, 0, 0, 0, 0, 0, 0, + 0x10, 0x4E, 0x8B, 0x18, 0x74, 0xCD, 0x1C, 0x86, 0xEE, 0x1E, 0x90, 0xFF, 0x1E, 0x90, 0xFF, 0x04}, + /* Colors starting with 'e' (placeholder) */ + {0xFF, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}, /* Colors starting with 'f' */ - "irebrick\0 \213\032\032\315\046\046\356\054\054\377\060\060\262\042\042\4", - "loralWhite\0 \377\372\360\0", - "orestGreen\0 \042\213\042\0", - "uchsia\0 \377\000\377\0", + {'i', 'r', 'e', 'b', 'r', 'i', 'c', 'k', 0, 0, 0, 0, 0, 0, 0, 0, + 0x8B, 0x1A, 0x1A, 0xCD, 0x26, 0x26, 0xEE, 0x2C, 0x2C, 0xFF, 0x30, 0x30, 0xB2, 0x22, 0x22, 0x04}, + {'l', 'o', 'r', 'a', 'l', 'W', 'h', 'i', 't', 'e', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0xFF, 0xFA, 0xF0, 0x00}, + {'o', 'r', 'e', 's', 't', 'G', 'r', 'e', 'e', 'n', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x22, 0x8B, 0x22, 0x00}, + {'u', 'c', 'h', 's', 'i', 'a', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0xFF, 0x00, 0xFF, 0x00}, /* Colors starting with 'g' */ - "ainsboro\0 \334\334\334\0", - "hostWhite\0 \370\370\377\0", - "old\0 \213\165\000\315\255\000\356\311\000\377\327\000\377\327\000\4", - "oldenrod\0 \213\151\024\315\233\035\356\264\042\377\301\045\332\245\040\4", - "ray\0\024\024\024\022\022\022\017\017\017\015\015\015\012\012\012" - "\010\010\010\005\005\005\003\003\003\200\200\200\10", - "ray0\0 \000\000\000\0", - "reen\0 \000\213\000\000\315\000\000\356\000\000\377\000\000\200\000\4", - "reenYellow\0 \255\377\057\0", - "rey\0\024\024\024\022\022\022\017\017\017\015\015\015\012\012\012" - "\010\010\010\005\005\005\003\003\003\200\200\200\10", - "rey0\0 \000\000\000\0", + {'a', 'i', 'n', 's', 'b', 'o', 'r', 'o', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0xDC, 0xDC, 0xDC, 0x00}, + {'h', 'o', 's', 't', 'W', 'h', 'i', 't', 'e', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0xF8, 0xF8, 0xFF, 0x00}, + {'o', 'l', 'd', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x8B, 0x75, 0x00, 0xCD, 0xAD, 0x00, 0xEE, 0xC9, 0x00, 0xFF, 0xD7, 0x00, 0xFF, 0xD7, 0x00, 0x04}, + {'o', 'l', 'd', 'e', 'n', 'r', 'o', 'd', 0, 0, 0, 0, 0, 0, 0, 0, + 0x8B, 0x69, 0x14, 0xCD, 0x9B, 0x1D, 0xEE, 0xB4, 0x22, 0xFF, 0xC1, 0x25, 0xDA, 0xA5, 0x20, 0x04}, + {'r', 'a', 'y', 0, + 0x14, 0x14, 0x14, 0x12, 0x12, 0x12, 0x0F, 0x0F, 0x0F, 0x0D, 0x0D, 0x0D, 0x0A, 0x0A, 0x0A, 0x08, 0x08, 0x08, 0x05, 0x05, 0x05, 0x03, 0x03, 0x03, 0x80, 0x80, 0x80, 0x08}, + {'r', 'a', 'y', '0', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x00, 0x00, 0x00, 0x00}, + {'r', 'e', 'e', 'n', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x00, 0x8B, 0x00, 0x00, 0xCD, 0x00, 0x00, 0xEE, 0x00, 0x00, 0xFF, 0x00, 0x00, 0x80, 0x00, 0x04}, + {'r', 'e', 'e', 'n', 'Y', 'e', 'l', 'l', 'o', 'w', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0xAD, 0xFF, 0x2F, 0x00}, + {'r', 'e', 'y', 0, + 0x14, 0x14, 0x14, 0x12, 0x12, 0x12, 0x0F, 0x0F, 0x0F, 0x0D, 0x0D, 0x0D, 0x0A, 0x0A, 0x0A, 0x08, 0x08, 0x08, 0x05, 0x05, 0x05, 0x03, 0x03, 0x03, 0x80, 0x80, 0x80, 0x08}, + {'r', 'e', 'y', '0', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x00, 0x00, 0x00, 0x00}, /* Colors starting with 'h' */ - "oneydew\0 \203\213\203\301\315\301\340\356\340\360\377\360\360\377\360\4", - "otPink\0 \213\072\142\315\140\220\356\152\247\377\156\264\377\151\264\4", + {'o', 'n', 'e', 'y', 'd', 'e', 'w', 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x83, 0x8B, 0x83, 0xC1, 0xCD, 0xC1, 0xE0, 0xEE, 0xE0, 0xF0, 0xFF, 0xF0, 0xF0, 0xFF, 0xF0, 0x04}, + {'o', 't', 'P', 'i', 'n', 'k', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x8B, 0x3A, 0x62, 0xCD, 0x60, 0x90, 0xEE, 0x6A, 0xA7, 0xFF, 0x6E, 0xB4, 0xFF, 0x69, 0xB4, 0x04}, /* Colors starting with 'i' */ - "ndianRed\0 \213\072\072\315\125\125\356\143\143\377\152\152\315\134\134\4", - "ndigo\0 \113\000\202\0", - "vory\0 \213\213\203\315\315\301\356\356\340\377\377\360\377\377\360\4", - /* Colors starting with 'j' */ - "\377 \0" /* placeholder */, + {'n', 'd', 'i', 'a', 'n', 'R', 'e', 'd', 0, 0, 0, 0, 0, 0, 0, 0, + 0x8B, 0x3A, 0x3A, 0xCD, 0x55, 0x55, 0xEE, 0x63, 0x63, 0xFF, 0x6A, 0x6A, 0xCD, 0x5C, 0x5C, 0x04}, + {'n', 'd', 'i', 'g', 'o', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x4B, 0x00, 0x82, 0x00}, + {'v', 'o', 'r', 'y', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x8B, 0x8B, 0x83, 0xCD, 0xCD, 0xC1, 0xEE, 0xEE, 0xE0, 0xFF, 0xFF, 0xF0, 0xFF, 0xFF, 0xF0, 0x04}, + /* Colors starting with 'j' (placeholder) */ + {0xFF, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}, /* Colors starting with 'k' */ - "haki\0 \213\206\116\315\306\163\356\346\205\377\366\217\360\346\214\4", + {'h', 'a', 'k', 'i', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x8B, 0x86, 0x4E, 0xCD, 0xC6, 0x73, 0xEE, 0xE6, 0x85, 0xFF, 0xF6, 0x8F, 0xF0, 0xE6, 0x8C, 0x04}, /* Colors starting with 'l' */ - "avender\0 \346\346\372\0", - "avenderBlush\0 \213\203\206\315\301\305\356\340\345\377\360\365\377\360\365\4", - "awnGreen\0 \174\374\000\0", - "emonChiffon\0 \213\211\160\315\311\245\356\351\277\377\372\315\377\372\315\4", - "ightBlue\0 \150\203\213\232\300\315\262\337\356\277\357\377\255\330\346\4", - "ightCoral\0 \360\200\200\0", - "ightCyan\0 \172\213\213\264\315\315\321\356\356\340\377\377\340\377\377\4", - "ightGoldenrod\0 \213\201\114\315\276\160\356\334\202\377\354\213\356\335\202\4", - "ightGoldenrodYellow\0 \372\372\322\0", - "ightGray\0 \323\323\323\0", - "ightGreen\0 \220\356\220\0", - "ightGrey\0 \323\323\323\0", - "ightPink\0 \213\137\145\315\214\225\356\242\255\377\256\271\377\266\301\4", - "ightSalmon\0 \213\127\102\315\201\142\356\225\162\377\240\172\377\240\172\4", - "ightSeaGreen\0 \040\262\252\0", - "ightSkyBlue\0 \140\173\213\215\266\315\244\323\356\260\342\377\207\316\372\4", - "ightSlateBlue\0 \204\160\377\0", - "ightSlateGray\0 \167\210\231\0", - "ightSlateGrey\0 \167\210\231\0", - "ightSteelBlue\0 \156\173\213\242\265\315\274\322\356\312\341\377\260\304\336\4", - "ightYellow\0 \213\213\172\315\315\264\356\356\321\377\377\340\377\377\340\4", - "ime\0 \000\377\000\0", - "imeGreen\0 \062\315\062\0", - "inen\0 \372\360\346\0", + {'a', 'v', 'e', 'n', 'd', 'e', 'r', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0xE6, 0xE6, 0xFA, 0x00}, + {'a', 'v', 'e', 'n', 'd', 'e', 'r', 'B', 'l', 'u', 's', 'h', 0, 0, 0, 0, + 0x8B, 0x83, 0x86, 0xCD, 0xC1, 0xC5, 0xEE, 0xE0, 0xE5, 0xFF, 0xF0, 0xF5, 0xFF, 0xF0, 0xF5, 0x04}, + {'a', 'w', 'n', 'G', 'r', 'e', 'e', 'n', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x7C, 0xFC, 0x00, 0x00}, + {'e', 'm', 'o', 'n', 'C', 'h', 'i', 'f', 'f', 'o', 'n', 0, 0, 0, 0, 0, + 0x8B, 0x89, 0x70, 0xCD, 0xC9, 0xA5, 0xEE, 0xE9, 0xBF, 0xFF, 0xFA, 0xCD, 0xFF, 0xFA, 0xCD, 0x04}, + {'i', 'g', 'h', 't', 'B', 'l', 'u', 'e', 0, 0, 0, 0, 0, 0, 0, 0, + 0x68, 0x83, 0x8B, 0x9A, 0xC0, 0xCD, 0xB2, 0xDF, 0xEE, 0xBF, 0xEF, 0xFF, 0xAD, 0xD8, 0xE6, 0x04}, + {'i', 'g', 'h', 't', 'C', 'o', 'r', 'a', 'l', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0xF0, 0x80, 0x80, 0x00}, + {'i', 'g', 'h', 't', 'C', 'y', 'a', 'n', 0, 0, 0, 0, 0, 0, 0, 0, + 0x7A, 0x8B, 0x8B, 0xB4, 0xCD, 0xCD, 0xD1, 0xEE, 0xEE, 0xE0, 0xFF, 0xFF, 0xE0, 0xFF, 0xFF, 0x04}, + {'i', 'g', 'h', 't', 'G', 'o', 'l', 'd', 'e', 'n', 'r', 'o', 'd', 0, 0, 0, + 0x8B, 0x81, 0x4C, 0xCD, 0xBE, 0x70, 0xEE, 0xDC, 0x82, 0xFF, 0xEC, 0x8B, 0xEE, 0xDD, 0x82, 0x04}, + {'i', 'g', 'h', 't', 'G', 'o', 'l', 'd', 'e', 'n', 'r', 'o', 'd', 'Y', 'e', 'l', 'l', 'o', 'w', 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0xFA, 0xFA, 0xD2, 0x00}, + {'i', 'g', 'h', 't', 'G', 'r', 'a', 'y', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0xD3, 0xD3, 0xD3, 0x00}, + {'i', 'g', 'h', 't', 'G', 'r', 'e', 'e', 'n', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x90, 0xEE, 0x90, 0x00}, + {'i', 'g', 'h', 't', 'G', 'r', 'e', 'y', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0xD3, 0xD3, 0xD3, 0x00}, + {'i', 'g', 'h', 't', 'P', 'i', 'n', 'k', 0, 0, 0, 0, 0, 0, 0, 0, + 0x8B, 0x5F, 0x65, 0xCD, 0x8C, 0x95, 0xEE, 0xA2, 0xAD, 0xFF, 0xAE, 0xB9, 0xFF, 0xB6, 0xC1, 0x04}, + {'i', 'g', 'h', 't', 'S', 'a', 'l', 'm', 'o', 'n', 0, 0, 0, 0, 0, 0, + 0x8B, 0x57, 0x42, 0xCD, 0x81, 0x62, 0xEE, 0x95, 0x72, 0xFF, 0xA0, 0x7A, 0xFF, 0xA0, 0x7A, 0x04}, + {'i', 'g', 'h', 't', 'S', 'e', 'a', 'G', 'r', 'e', 'e', 'n', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x20, 0xB2, 0xAA, 0x00}, + {'i', 'g', 'h', 't', 'S', 'k', 'y', 'B', 'l', 'u', 'e', 0, 0, 0, 0, 0, + 0x60, 0x7B, 0x8B, 0x8D, 0xB6, 0xCD, 0xA4, 0xD3, 0xEE, 0xB0, 0xE2, 0xFF, 0x87, 0xCE, 0xFA, 0x04}, + {'i', 'g', 'h', 't', 'S', 'l', 'a', 't', 'e', 'B', 'l', 'u', 'e', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x84, 0x70, 0xFF, 0x00}, + {'i', 'g', 'h', 't', 'S', 'l', 'a', 't', 'e', 'G', 'r', 'a', 'y', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x77, 0x88, 0x99, 0x00}, + {'i', 'g', 'h', 't', 'S', 'l', 'a', 't', 'e', 'G', 'r', 'e', 'y', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x77, 0x88, 0x99, 0x00}, + {'i', 'g', 'h', 't', 'S', 't', 'e', 'e', 'l', 'B', 'l', 'u', 'e', 0, 0, 0, + 0x6E, 0x7B, 0x8B, 0xA2, 0xB5, 0xCD, 0xBC, 0xD2, 0xEE, 0xCA, 0xE1, 0xFF, 0xB0, 0xC4, 0xDE, 0x04}, + {'i', 'g', 'h', 't', 'Y', 'e', 'l', 'l', 'o', 'w', 0, 0, 0, 0, 0, 0, + 0x8B, 0x8B, 0x7A, 0xCD, 0xCD, 0xB4, 0xEE, 0xEE, 0xD1, 0xFF, 0xFF, 0xE0, 0xFF, 0xFF, 0xE0, 0x04}, + {'i', 'm', 'e', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x00, 0xFF, 0x00, 0x00}, + {'i', 'm', 'e', 'G', 'r', 'e', 'e', 'n', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x32, 0xCD, 0x32, 0x00}, + {'i', 'n', 'e', 'n', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0xFA, 0xF0, 0xE6, 0x00}, /* Colors starting with 'm' */ - "agenta\0 \213\000\213\315\000\315\356\000\356\377\000\377\377\000\377\4", - "aroon\0 \213\034\142\315\051\220\356\060\247\377\064\263\200\000\000\4", - "ediumAquamarine\0 \146\315\252\0", - "ediumBlue\0 \000\000\315\0", - "ediumOrchid\0 \172\067\213\264\122\315\321\137\356\340\146\377\272\125\323\4", - "ediumPurple\0 \135\107\213\211\150\315\237\171\356\253\202\377\223\160\333\4", - "ediumSeaGreen\0 \074\263\161\0", - "ediumSlateBlue\0 \173\150\356\0", - "ediumSpringGreen\0 \000\372\232\0", - "ediumTurquoise\0 \110\321\314\0", - "ediumVioletRed\0 \307\025\205\0", - "idnightBlue\0 \031\031\160\0", - "intCream\0 \365\377\372\0", - "istyRose\0 \213\175\173\315\267\265\356\325\322\377\344\341\377\344\341\4", - "occasin\0 \377\344\265\0", + {'a', 'g', 'e', 'n', 't', 'a', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x8B, 0x00, 0x8B, 0xCD, 0x00, 0xCD, 0xEE, 0x00, 0xEE, 0xFF, 0x00, 0xFF, 0xFF, 0x00, 0xFF, 0x04}, + {'a', 'r', 'o', 'o', 'n', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x8B, 0x1C, 0x62, 0xCD, 0x29, 0x90, 0xEE, 0x30, 0xA7, 0xFF, 0x34, 0xB3, 0x80, 0x00, 0x00, 0x04}, + {'e', 'd', 'i', 'u', 'm', 'A', 'q', 'u', 'a', 'm', 'a', 'r', 'i', 'n', 'e', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x66, 0xCD, 0xAA, 0x00}, + {'e', 'd', 'i', 'u', 'm', 'B', 'l', 'u', 'e', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x00, 0x00, 0xCD, 0x00}, + {'e', 'd', 'i', 'u', 'm', 'O', 'r', 'c', 'h', 'i', 'd', 0, 0, 0, 0, 0, + 0x7A, 0x37, 0x8B, 0xB4, 0x52, 0xCD, 0xD1, 0x5F, 0xEE, 0xE0, 0x66, 0xFF, 0xBA, 0x55, 0xD3, 0x04}, + {'e', 'd', 'i', 'u', 'm', 'P', 'u', 'r', 'p', 'l', 'e', 0, 0, 0, 0, 0, + 0x5D, 0x47, 0x8B, 0x89, 0x68, 0xCD, 0x9F, 0x79, 0xEE, 0xAB, 0x82, 0xFF, 0x93, 0x70, 0xDB, 0x04}, + {'e', 'd', 'i', 'u', 'm', 'S', 'e', 'a', 'G', 'r', 'e', 'e', 'n', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x3C, 0xB3, 0x71, 0x00}, + {'e', 'd', 'i', 'u', 'm', 'S', 'l', 'a', 't', 'e', 'B', 'l', 'u', 'e', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x7B, 0x68, 0xEE, 0x00}, + {'e', 'd', 'i', 'u', 'm', 'S', 'p', 'r', 'i', 'n', 'g', 'G', 'r', 'e', 'e', 'n', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x00, 0xFA, 0x9A, 0x00}, + {'e', 'd', 'i', 'u', 'm', 'T', 'u', 'r', 'q', 'u', 'o', 'i', 's', 'e', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x48, 0xD1, 0xCC, 0x00}, + {'e', 'd', 'i', 'u', 'm', 'V', 'i', 'o', 'l', 'e', 't', 'R', 'e', 'd', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0xC7, 0x15, 0x85, 0x00}, + {'i', 'd', 'n', 'i', 'g', 'h', 't', 'B', 'l', 'u', 'e', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x19, 0x19, 0x70, 0x00}, + {'i', 'n', 't', 'C', 'r', 'e', 'a', 'm', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0xF5, 0xFF, 0xFA, 0x00}, + {'i', 's', 't', 'y', 'R', 'o', 's', 'e', 0, 0, 0, 0, 0, 0, 0, 0, + 0x8B, 0x7D, 0x7B, 0xCD, 0xB7, 0xB5, 0xEE, 0xD5, 0xD2, 0xFF, 0xE4, 0xE1, 0xFF, 0xE4, 0xE1, 0x04}, + {'o', 'c', 'c', 'a', 's', 'i', 'n', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0xFF, 0xE4, 0xB5, 0x00}, /* Colors starting with 'n' */ - "avajoWhite\0 \213\171\136\315\263\213\356\317\241\377\336\255\377\336\255\4", - "avy\0 \000\000\200\0", - "avyBlue\0 \000\000\200\0", + {'a', 'v', 'a', 'j', 'o', 'W', 'h', 'i', 't', 'e', 0, 0, 0, 0, 0, 0, + 0x8B, 0x79, 0x5E, 0xCD, 0xB3, 0x8B, 0xEE, 0xCF, 0xA1, 0xFF, 0xDE, 0xAD, 0xFF, 0xDE, 0xAD, 0x04}, + {'a', 'v', 'y', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x00, 0x00, 0x80, 0x00}, + {'a', 'v', 'y', 'B', 'l', 'u', 'e', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x00, 0x00, 0x80, 0x00}, /* Colors starting with 'o' */ - "ldLace\0 \375\365\346\0", - "live\0 \200\200\000\0", - "liveDrab\0 \151\213\042\232\315\062\263\356\072\300\377\076\153\216\043\4", - "range\0 \213\132\000\315\205\000\356\232\000\377\245\000\377\245\000\4", - "rangeRed\0 \213\045\000\315\067\000\356\100\000\377\105\000\377\105\000\4", - "rchid\0 \213\107\211\315\151\311\356\172\351\377\203\372\332\160\326\4", + {'l', 'd', 'L', 'a', 'c', 'e', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0xFD, 0xF5, 0xE6, 0x00}, + {'l', 'i', 'v', 'e', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x80, 0x80, 0x00, 0x00}, + {'l', 'i', 'v', 'e', 'D', 'r', 'a', 'b', 0, 0, 0, 0, 0, 0, 0, 0, + 0x69, 0x8B, 0x22, 0x9A, 0xCD, 0x32, 0xB3, 0xEE, 0x3A, 0xC0, 0xFF, 0x3E, 0x6B, 0x8E, 0x23, 0x04}, + {'r', 'a', 'n', 'g', 'e', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x8B, 0x5A, 0x00, 0xCD, 0x85, 0x00, 0xEE, 0x9A, 0x00, 0xFF, 0xA5, 0x00, 0xFF, 0xA5, 0x00, 0x04}, + {'r', 'a', 'n', 'g', 'e', 'R', 'e', 'd', 0, 0, 0, 0, 0, 0, 0, 0, + 0x8B, 0x25, 0x00, 0xCD, 0x37, 0x00, 0xEE, 0x40, 0x00, 0xFF, 0x45, 0x00, 0xFF, 0x45, 0x00, 0x04}, + {'r', 'c', 'h', 'i', 'd', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x8B, 0x47, 0x89, 0xCD, 0x69, 0xC9, 0xEE, 0x7A, 0xE9, 0xFF, 0x83, 0xFA, 0xDA, 0x70, 0xD6, 0x04}, /* Colors starting with 'p' */ - "aleGoldenrod\0 \356\350\252\0", - "aleGreen\0 \124\213\124\174\315\174\220\356\220\232\377\232\230\373\230\4", - "aleTurquoise\0 \146\213\213\226\315\315\256\356\356\273\377\377\257\356\356\4", - "aleVioletRed\0 \213\107\135\315\150\211\356\171\237\377\202\253\333\160\223\4", - "apayaWhip\0 \377\357\325\0", - "eachPuff\0 \213\167\145\315\257\225\356\313\255\377\332\271\377\332\271\4", - "eru\0 \315\205\077\0", - "ink\0 \213\143\154\315\221\236\356\251\270\377\265\305\377\300\313\4", - "lum\0 \213\146\213\315\226\315\356\256\356\377\273\377\335\240\335\4", - "owderBlue\0 \260\340\346\0", - "urple\0 \125\032\213\175\046\315\221\054\356\233\060\377\200\000\200\4", - /* Colors starting with 'q' */ - "\377 \0" /* placeholder */, + {'a', 'l', 'e', 'G', 'o', 'l', 'd', 'e', 'n', 'r', 'o', 'd', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0xEE, 0xE8, 0xAA, 0x00}, + {'a', 'l', 'e', 'G', 'r', 'e', 'e', 'n', 0, 0, 0, 0, 0, 0, 0, 0, + 0x54, 0x8B, 0x54, 0x7C, 0xCD, 0x7C, 0x90, 0xEE, 0x90, 0x9A, 0xFF, 0x9A, 0x98, 0xFB, 0x98, 0x04}, + {'a', 'l', 'e', 'T', 'u', 'r', 'q', 'u', 'o', 'i', 's', 'e', 0, 0, 0, 0, + 0x66, 0x8B, 0x8B, 0x96, 0xCD, 0xCD, 0xAE, 0xEE, 0xEE, 0xBB, 0xFF, 0xFF, 0xAF, 0xEE, 0xEE, 0x04}, + {'a', 'l', 'e', 'V', 'i', 'o', 'l', 'e', 't', 'R', 'e', 'd', 0, 0, 0, 0, + 0x8B, 0x47, 0x5D, 0xCD, 0x68, 0x89, 0xEE, 0x79, 0x9F, 0xFF, 0x82, 0xAB, 0xDB, 0x70, 0x93, 0x04}, + {'a', 'p', 'a', 'y', 'a', 'W', 'h', 'i', 'p', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0xFF, 0xEF, 0xD5, 0x00}, + {'e', 'a', 'c', 'h', 'P', 'u', 'f', 'f', 0, 0, 0, 0, 0, 0, 0, 0, + 0x8B, 0x77, 0x65, 0xCD, 0xAF, 0x95, 0xEE, 0xCB, 0xAD, 0xFF, 0xDA, 0xB9, 0xFF, 0xDA, 0xB9, 0x04}, + {'e', 'r', 'u', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0xCD, 0x85, 0x3F, 0x00}, + {'i', 'n', 'k', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x8B, 0x63, 0x6C, 0xCD, 0x91, 0x9E, 0xEE, 0xA9, 0xB8, 0xFF, 0xB5, 0xC5, 0xFF, 0xC0, 0xCB, 0x04}, + {'l', 'u', 'm', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x8B, 0x66, 0x8B, 0xCD, 0x96, 0xCD, 0xEE, 0xAE, 0xEE, 0xFF, 0xBB, 0xFF, 0xDD, 0xA0, 0xDD, 0x04}, + {'o', 'w', 'd', 'e', 'r', 'B', 'l', 'u', 'e', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0xB0, 0xE0, 0xE6, 0x00}, + {'u', 'r', 'p', 'l', 'e', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x55, 0x1A, 0x8B, 0x7D, 0x26, 0xCD, 0x91, 0x2C, 0xEE, 0x9B, 0x30, 0xFF, 0x80, 0x00, 0x80, 0x04}, + /* Colors starting with 'q' (placeholder)*/ + {0xFF, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}, /* Colors starting with 'r' */ - "ed\0 \213\000\000\315\000\000\356\000\000\377\000\000\377\000\000\4", - "osyBrown\0 \213\151\151\315\233\233\356\264\264\377\301\301\274\217\217\4", - "oyalBlue\0 \047\100\213\072\137\315\103\156\356\110\166\377\101\151\341\4", + {'e', 'd', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x8B, 0x00, 0x00, 0xCD, 0x00, 0x00, 0xEE, 0x00, 0x00, 0xFF, 0x00, 0x00, 0xFF, 0x00, 0x00, 0x04}, + {'o', 's', 'y', 'B', 'r', 'o', 'w', 'n', 0, 0, 0, 0, 0, 0, 0, 0, + 0x8B, 0x69, 0x69, 0xCD, 0x9B, 0x9B, 0xEE, 0xB4, 0xB4, 0xFF, 0xC1, 0xC1, 0xBC, 0x8F, 0x8F, 0x04}, + {'o', 'y', 'a', 'l', 'B', 'l', 'u', 'e', 0, 0, 0, 0, 0, 0, 0, 0, + 0x27, 0x40, 0x8B, 0x3A, 0x5F, 0xCD, 0x43, 0x6E, 0xEE, 0x48, 0x76, 0xFF, 0x41, 0x69, 0xE1, 0x04}, /* Colors starting with 's' */ - "addleBrown\0 \213\105\023\0", - "almon\0 \213\114\071\315\160\124\356\202\142\377\214\151\372\200\162\4", - "andyBrown\0 \364\244\140\0", - "eaGreen\0 \056\213\127\103\315\200\116\356\224\124\377\237\056\213\127\4", - "eashell\0 \213\206\202\315\305\277\356\345\336\377\365\356\377\365\356\4", - "ienna\0 \213\107\046\315\150\071\356\171\102\377\202\107\240\122\055\4", - "ilver\0 \300\300\300\0", - "kyBlue\0 \112\160\213\154\246\315\176\300\356\207\316\377\207\316\353\4", - "lateBlue\0 \107\074\213\151\131\315\172\147\356\203\157\377\152\132\315\4", - "lateGray\0 \154\173\213\237\266\315\271\323\356\306\342\377\160\200\220\4", - "lateGrey\0 \160\200\220\0", - "now\0 \213\211\211\315\311\311\356\351\351\377\372\372\377\372\372\4", - "pringGreen\0 \000\213\105\000\315\146\000\356\166\000\377\177\000\377\177\4", - "teelBlue\0 \066\144\213\117\224\315\134\254\356\143\270\377\106\202\264\4", + {'a', 'd', 'd', 'l', 'e', 'B', 'r', 'o', 'w', 'n', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x8B, 0x45, 0x13, 0x00}, + {'a', 'l', 'm', 'o', 'n', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x8B, 0x4C, 0x39, 0xCD, 0x70, 0x54, 0xEE, 0x82, 0x62, 0xFF, 0x8C, 0x69, 0xFA, 0x80, 0x72, 0x04}, + {'a', 'n', 'd', 'y', 'B', 'r', 'o', 'w', 'n', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0xF4, 0xA4, 0x60, 0x00}, + {'e', 'a', 'G', 'r', 'e', 'e', 'n', 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x2E, 0x8B, 0x57, 0x43, 0xCD, 0x80, 0x4E, 0xEE, 0x94, 0x54, 0xFF, 0x9F, 0x2E, 0x8B, 0x57, 0x04}, + {'e', 'a', 's', 'h', 'e', 'l', 'l', 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x8B, 0x86, 0x82, 0xCD, 0xC5, 0xBF, 0xEE, 0xE5, 0xDE, 0xFF, 0xF5, 0xEE, 0xFF, 0xF5, 0xEE, 0x04}, + {'i', 'e', 'n', 'n', 'a', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x8B, 0x47, 0x26, 0xCD, 0x68, 0x39, 0xEE, 0x79, 0x42, 0xFF, 0x82, 0x47, 0xA0, 0x52, 0x2D, 0x04}, + {'i', 'l', 'v', 'e', 'r', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0xC0, 0xC0, 0xC0, 0x00}, + {'k', 'y', 'B', 'l', 'u', 'e', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x4A, 0x70, 0x8B, 0x6C, 0xA6, 0xCD, 0x7E, 0xC0, 0xEE, 0x87, 0xCE, 0xFF, 0x87, 0xCE, 0xEB, 0x04}, + {'l', 'a', 't', 'e', 'B', 'l', 'u', 'e', 0, 0, 0, 0, 0, 0, 0, 0, + 0x47, 0x3C, 0x8B, 0x69, 0x59, 0xCD, 0x7A, 0x67, 0xEE, 0x83, 0x6F, 0xFF, 0x6A, 0x5A, 0xCD, 0x04}, + {'l', 'a', 't', 'e', 'G', 'r', 'a', 'y', 0, 0, 0, 0, 0, 0, 0, 0, + 0x6C, 0x7B, 0x8B, 0x9F, 0xB6, 0xCD, 0xB9, 0xD3, 0xEE, 0xC6, 0xE2, 0xFF, 0x70, 0x80, 0x90, 0x04}, + {'l', 'a', 't', 'e', 'G', 'r', 'e', 'y', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x70, 0x80, 0x90, 0x00}, + {'n', 'o', 'w', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x8B, 0x89, 0x89, 0xCD, 0xC9, 0xC9, 0xEE, 0xE9, 0xE9, 0xFF, 0xFA, 0xFA, 0xFF, 0xFA, 0xFA, 0x04}, + {'p', 'r', 'i', 'n', 'g', 'G', 'r', 'e', 'e', 'n', 0, 0, 0, 0, 0, 0, + 0x00, 0x8B, 0x45, 0x00, 0xCD, 0x66, 0x00, 0xEE, 0x76, 0x00, 0xFF, 0x7F, 0x00, 0xFF, 0x7F, 0x04}, + {'t', 'e', 'e', 'l', 'B', 'l', 'u', 'e', 0, 0, 0, 0, 0, 0, 0, 0, + 0x36, 0x64, 0x8B, 0x4F, 0x94, 0xCD, 0x5C, 0xAC, 0xEE, 0x63, 0xB8, 0xFF, 0x46, 0x82, 0xB4, 0x04}, /* Colors starting with 't' */ - "an\0 \213\132\053\315\205\077\356\232\111\377\245\117\322\264\214\4", - "eal\0 \000\200\200\0", - "histle\0 \213\173\213\315\265\315\356\322\356\377\341\377\330\277\330\4", - "omato\0 \213\066\046\315\117\071\356\134\102\377\143\107\377\143\107\4", - "urquoise\0 \000\206\213\000\305\315\000\345\356\000\365\377\100\340\320\4", - /* Colors starting with 'u' */ - "\377 \0" /* placeholder */, + {'a', 'n', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x8B, 0x5A, 0x2B, 0xCD, 0x85, 0x3F, 0xEE, 0x9A, 0x49, 0xFF, 0xA5, 0x4F, 0xD2, 0xB4, 0x8C, 0x04}, + {'e', 'a', 'l', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x00, 0x80, 0x80, 0x00}, + {'h', 'i', 's', 't', 'l', 'e', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x8B, 0x7B, 0x8B, 0xCD, 0xB5, 0xCD, 0xEE, 0xD2, 0xEE, 0xFF, 0xE1, 0xFF, 0xD8, 0xBF, 0xD8, 0x04}, + {'o', 'm', 'a', 't', 'o', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x8B, 0x36, 0x26, 0xCD, 0x4F, 0x39, 0xEE, 0x5C, 0x42, 0xFF, 0x63, 0x47, 0xFF, 0x63, 0x47, 0x04}, + {'u', 'r', 'q', 'u', 'o', 'i', 's', 'e', 0, 0, 0, 0, 0, 0, 0, 0, + 0x00, 0x86, 0x8B, 0x00, 0xC5, 0xCD, 0x00, 0xE5, 0xEE, 0x00, 0xF5, 0xFF, 0x40, 0xE0, 0xD0, 0x04}, + /* Colors starting with 'u' (placeholder) */ + {0xFF, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}, /* Colors starting with 'v' */ - "iolet\0 \356\202\356\0", - "ioletRed\0 \213\042\122\315\062\170\356\072\214\377\076\226\320\040\220\4", + {'i', 'o', 'l', 'e', 't', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0xEE, 0x82, 0xEE, 0x00}, + {'i', 'o', 'l', 'e', 't', 'R', 'e', 'd', 0, 0, 0, 0, 0, 0, 0, 0, + 0x8B, 0x22, 0x52, 0xCD, 0x32, 0x78, 0xEE, 0x3A, 0x8C, 0xFF, 0x3E, 0x96, 0xD0, 0x20, 0x90, 0x04}, /* Colors starting with 'w' */ - "heat\0 \213\176\146\315\272\226\356\330\256\377\347\272\365\336\263\4", - "hite\0 \377\377\377\0", - "hiteSmoke\0 \365\365\365\0", - /* Colors starting with 'x' */ - "\377 \0" /* placeholder */, + {'h', 'e', 'a', 't', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x8B, 0x7E, 0x66, 0xCD, 0xBA, 0x96, 0xEE, 0xD8, 0xAE, 0xFF, 0xE7, 0xBA, 0xF5, 0xDE, 0xB3, 0x04}, + {'h', 'i', 't', 'e', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0xFF, 0xFF, 0xFF, 0x00}, + {'h', 'i', 't', 'e', 'S', 'm', 'o', 'k', 'e', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0xF5, 0xF5, 0xF5, 0x00}, + /* Colors starting with 'x' (placeholder) */ + {0xFF, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}, /* Colors starting with 'y' */ - "ellow\0 \213\213\000\315\315\000\356\356\000\377\377\000\377\377\000\4", - "ellowGreen\0 \232\315\062\0" + {'e', 'l', 'l', 'o', 'w', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x8B, 0x8B, 0x00, 0xCD, 0xCD, 0x00, 0xEE, 0xEE, 0x00, 0xFF, 0xFF, 0x00, 0xFF, 0xFF, 0x00, 0x04}, + {'e', 'l', 'l', 'o', 'w', 'G', 'r', 'e', 'e', 'n', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0x9A, 0xCD, 0x32, 0x00} }; /* @@ -276,8 +427,8 @@ parseHex64bit( static int colorcmp( const char *spec, - const char *pname, - int *special) + const unsigned char *pname, + unsigned short *special) { int r; int c, d; @@ -325,7 +476,7 @@ colorcmp( r = 1; } - *special = num; + *special = (unsigned short)num; return r; } @@ -386,9 +537,10 @@ XParseColor( * p = pointer to current element being considered. */ - int size, num; + int size; + unsigned short num; const elem *p; - const char *q; + const unsigned char *q; int r = (spec[0] - 'A') & 0xdf; if (r >= (int) sizeof(az) - 1) { @@ -416,7 +568,7 @@ XParseColor( if (((*p)[31] != 8) || num > 100) { return 0; } - num = (num * 255 + 50) / 100; + num = (unsigned short)((num * 255 + 50) / 100); if ((num == 230) || (num == 128)) { /* * Those two entries have a deviation i.r.t the table. @@ -428,9 +580,9 @@ XParseColor( colorPtr->red = colorPtr->green = colorPtr->blue = num; } else { q = *p + 28 - num * 3; - colorPtr->red = ((RED(q) << 8) | RED(q)); - colorPtr->green = ((GREEN(q) << 8) | GREEN(q)); - colorPtr->blue = ((BLUE(q) << 8) | BLUE(q)); + colorPtr->red = (unsigned short)((RED(q) << 8) | RED(q)); + colorPtr->green = (unsigned short)((GREEN(q) << 8) | GREEN(q)); + colorPtr->blue = (unsigned short)((BLUE(q) << 8) | BLUE(q)); } } colorPtr->pixel = TkpGetPixel(colorPtr); diff --git a/xlib/xdraw.c b/xlib/xdraw.c index 0163b1c..0142ff6 100644 --- a/xlib/xdraw.c +++ b/xlib/xdraw.c @@ -37,10 +37,10 @@ XDrawLine( { XPoint points[2]; - points[0].x = x1; - points[0].y = y1; - points[1].x = x2; - points[1].y = y2; + points[0].x = (short)x1; + points[0].y = (short)y1; + points[1].x = (short)x2; + points[1].y = (short)y2; return XDrawLines(display, d, gc, points, 2, CoordModeOrigin); } @@ -72,10 +72,10 @@ XFillRectangle( unsigned int height) { XRectangle rectangle; - rectangle.x = x; - rectangle.y = y; - rectangle.width = width; - rectangle.height = height; + rectangle.x = (short)x; + rectangle.y = (short)y; + rectangle.width = (unsigned short)width; + rectangle.height = (unsigned short)height; return XFillRectangles(display, d, gc, &rectangle, 1); } @@ -381,7 +381,7 @@ XSetLineAttributes( int cap_style, int join_style) { - gc->line_width = line_width; + gc->line_width = (int)line_width; gc->line_style = line_style; gc->cap_style = cap_style; gc->join_style = join_style; @@ -473,8 +473,8 @@ XSetClipRectangles( while (n--) { XRectangle rect = *rectangles; - rect.x += clip_x_origin; - rect.y += clip_y_origin; + rect.x += (short)clip_x_origin; + rect.y += (short)clip_y_origin; TkUnionRectWithRegion(&rect, clipRgn, clipRgn); rectangles++; } @@ -664,24 +664,6 @@ XCreateWindow( return 0; } -int -XPointInRegion( - TCL_UNUSED(Region), - TCL_UNUSED(int), - TCL_UNUSED(int)) -{ - return 0; -} - -int -XUnionRegion( - TCL_UNUSED(Region), - TCL_UNUSED(Region), - TCL_UNUSED(Region)) -{ - return 0; -} - Region XPolygonRegion( TCL_UNUSED(XPoint *), diff --git a/xlib/ximage.c b/xlib/ximage.c index a948972..da5ca55 100644 --- a/xlib/ximage.c +++ b/xlib/ximage.c @@ -47,10 +47,11 @@ XCreateBitmapFromData( pix = Tk_GetPixmap(display, d, (int) width, (int) height, 1); gc = XCreateGC(display, pix, 0, NULL); if (gc == NULL) { + Tk_FreePixmap(display, pix); return None; } ximage = XCreateImage(display, NULL, 1, XYBitmap, 0, (char*) data, width, - height, 8, (width + 7) / 8); + height, 8, ((int)width + 7) / 8); if (ximage) { ximage->bitmap_bit_order = LSBFirst; _XInitImageFuncPtrs(ximage); |