merge trunk

tcltk · Jan 8, 2025 · 4f446f7 · 4f446f7
2 parents 1b63677 + 1c63482
commit 4f446f7
Show file tree

Hide file tree

Showing 22 changed files with 204 additions and 175 deletions.
diff --git a/.github/workflows/linux-build.yml b/.github/workflows/linux-build.yml
@@ -148,7 +148,7 @@ jobs:
           path: tcl
       - name: Setup Environment (compiler=${{ matrix.compiler }})
         run: |
-          sudo apt-get install libxss-dev libxft-dev xvfb libicu-dev
+          sudo apt-get install libxss-dev libxft-dev xvfb libicu-dev xfonts-75dpi xfonts-100dpi xfonts-scalable libxfont2 unifont
           mkdir "$HOME/install dir"
           touch tk/doc/man.macros tk/generic/tkStubInit.c
           echo "CFGOPT=$CFGOPT" >> $GITHUB_ENV

diff --git a/.github/workflows/linux-with-tcl8-build.yml b/.github/workflows/linux-with-tcl8-build.yml
@@ -23,7 +23,7 @@ jobs:
         compiler:
           - "gcc"
           - "clang"
-        cfgopt:
+        config:
           - ""
           - "CFLAGS=-DTK_NO_DEPRECATED=1"
           - "--disable-shared"
@@ -52,9 +52,9 @@ jobs:
           echo "BUILD_CONFIG_ID=$OPTS" >> $GITHUB_ENV
         working-directory: "."
         env:
-          CFGOPT: ${{ matrix.cfgopt }}
+          CFGOPT: ${{ matrix.config }}
           COMPILER: ${{ matrix.compiler }}
-          OPTS: ${{ matrix.compiler }}${{ matrix.cfgopt }}
+          OPTS: ${{ matrix.compiler }}${{ matrix.config }}
       - name: Configure and Build Tcl
         run: |
           ./configure $CFGOPT "--prefix=$HOME/install dir" || {
@@ -68,7 +68,7 @@ jobs:
           }
           echo "TCL_CONFIG_PATH=`pwd`" >> $GITHUB_ENV
         working-directory: tcl/unix
-      - name: Configure (opts=${{ matrix.cfgopt }})
+      - name: Configure (opts=${{ matrix.config }})
         run: |
           ./configure $CFGOPT --with-tcl=$TCL_CONFIG_PATH "--prefix=$HOME/install dir" || {
             cat config.log
@@ -111,7 +111,7 @@ jobs:
       matrix:
         compiler:
           - "gcc"
-        cfgopt:
+        config:
           - ""
           - "--disable-xft"
           - "--enable-symbols"
@@ -128,14 +128,14 @@ jobs:
           path: tcl
       - name: Setup Environment (compiler=${{ matrix.compiler }})
         run: |
-          sudo apt-get install libxss-dev libxft-dev xvfb libicu-dev
+          sudo apt-get install libxss-dev libxft-dev xvfb libicu-dev xfonts-75dpi xfonts-100dpi xfonts-scalable libxfont2 unifont
           mkdir "$HOME/install dir"
           touch tk/doc/man.macros tk/generic/tkStubInit.c
           echo "CFGOPT=$CFGOPT" >> $GITHUB_ENV
           echo "CC=$COMPILER" >> $GITHUB_ENV
         working-directory: "."
         env:
-          CFGOPT: ${{ matrix.cfgopt }}
+          CFGOPT: ${{ matrix.config }}
           COMPILER: ${{ matrix.compiler }}
       - name: Configure and Build Tcl
         run: |
@@ -150,7 +150,7 @@ jobs:
           }
           echo "TCL_CONFIG_PATH=`pwd`" >> $GITHUB_ENV
         working-directory: tcl/unix
-      - name: Configure ${{ matrix.cfgopt }}
+      - name: Configure ${{ matrix.config }}
         run: |
           ./configure $CFGOPT --with-tcl=$TCL_CONFIG_PATH "--prefix=$HOME/install dir" || {
             cat config.log

diff --git a/.github/workflows/linux-with-tcl91-build.yml b/.github/workflows/linux-with-tcl91-build.yml
@@ -24,7 +24,7 @@ jobs:
         compiler:
           - "gcc"
           - "clang"
-        cfgopt:
+        config:
           - ""
           - "CFLAGS=-DTK_NO_DEPRECATED=1"
           - "--disable-shared"
@@ -53,9 +53,9 @@ jobs:
           echo "BUILD_CONFIG_ID=$OPTS" >> $GITHUB_ENV
         working-directory: "."
         env:
-          CFGOPT: ${{ matrix.cfgopt }}
+          CFGOPT: ${{ matrix.config }}
           COMPILER: ${{ matrix.compiler }}
-          OPTS: ${{ matrix.compiler }}${{ matrix.cfgopt }}
+          OPTS: ${{ matrix.compiler }}${{ matrix.config }}
       - name: Configure and Build Tcl
         run: |
           ./configure $CFGOPT "--prefix=$HOME/install dir" || {
@@ -69,7 +69,7 @@ jobs:
           }
           echo "TCL_CONFIG_PATH=`pwd`" >> $GITHUB_ENV
         working-directory: tcl/unix
-      - name: Configure (opts=${{ matrix.cfgopt }})
+      - name: Configure (opts=${{ matrix.config }})
         run: |
           ./configure $CFGOPT --with-tcl=$TCL_CONFIG_PATH "--prefix=$HOME/install dir" || {
             cat config.log
@@ -112,7 +112,7 @@ jobs:
       matrix:
         compiler:
           - "gcc"
-        cfgopt:
+        config:
           - ""
           - "--disable-xft"
           - "--enable-symbols"
@@ -129,14 +129,14 @@ jobs:
           path: tcl
       - name: Setup Environment (compiler=${{ matrix.compiler }})
         run: |
-          sudo apt-get install libxss-dev libxft-dev xvfb libicu-dev
+          sudo apt-get install libxss-dev libxft-dev xvfb libicu-dev xfonts-75dpi xfonts-100dpi xfonts-scalable libxfont2 unifont
           mkdir "$HOME/install dir"
           touch tk/doc/man.macros tk/generic/tkStubInit.c
           echo "CFGOPT=$CFGOPT" >> $GITHUB_ENV
           echo "CC=$COMPILER" >> $GITHUB_ENV
         working-directory: "."
         env:
-          CFGOPT: ${{ matrix.cfgopt }}
+          CFGOPT: ${{ matrix.config }}
           COMPILER: ${{ matrix.compiler }}
       - name: Configure and Build Tcl
         run: |
@@ -151,7 +151,7 @@ jobs:
           }
           echo "TCL_CONFIG_PATH=`pwd`" >> $GITHUB_ENV
         working-directory: tcl/unix
-      - name: Configure ${{ matrix.cfgopt }}
+      - name: Configure ${{ matrix.config }}
         run: |
           ./configure $CFGOPT --with-tcl=$TCL_CONFIG_PATH "--prefix=$HOME/install dir" || {
             cat config.log

diff --git a/changes.md b/changes.md
@@ -19,6 +19,7 @@ to the userbase.
  - [inaccurate scrollbar error-message](https://core.tcl-lang.org/tk/tktview/f88118)
  - [Build tk 9.0.1 failed on macos 10.13](https://core.tcl-lang.org/tk/tktview/cb5d77)
  - [image svg upstream out of bound read nanosvg#262](https://core.tcl-lang.org/tk/tktview/121786)
+ - [wm iconbitmap does not correctly set the icon pixmap hint on macOS](https://core.tcl-lang.org/tk/tktview/13ac26)
 
 Release Tk 9.0.1 arises from the check-in with tag `core-9-0-1`.
 

diff --git a/macosx/tkMacOSXTest.c b/macosx/tkMacOSXTest.c
@@ -21,10 +21,10 @@
  * Forward declarations of procedures defined later in this file:
  */
 
-static Tcl_ObjCmdProc PressButtonObjCmd;
-static Tcl_ObjCmdProc MoveMouseObjCmd;
-static Tcl_ObjCmdProc InjectKeyEventObjCmd;
-static Tcl_ObjCmdProc MenuBarHeightObjCmd;
+static Tcl_ObjCmdProc TestpressbuttonObjCmd;
+static Tcl_ObjCmdProc TestmovemouseObjCmd;
+static Tcl_ObjCmdProc TestinjectkeyeventObjCmd;
+static Tcl_ObjCmdProc TestmenubarheightObjCmd;
 
 
 /*
@@ -52,17 +52,17 @@ TkplatformtestInit(
      * Add commands for platform specific tests on MacOS here.
      */
 
-    Tcl_CreateObjCommand(interp, "pressbutton", PressButtonObjCmd, NULL, NULL);
-    Tcl_CreateObjCommand(interp, "movemouse", MoveMouseObjCmd, NULL, NULL);
-    Tcl_CreateObjCommand(interp, "injectkeyevent", InjectKeyEventObjCmd, NULL, NULL);
-    Tcl_CreateObjCommand(interp, "menubarheight", MenuBarHeightObjCmd, NULL, NULL);
+    Tcl_CreateObjCommand(interp, "testpressbutton", TestpressbuttonObjCmd, NULL, NULL);
+    Tcl_CreateObjCommand(interp, "testmovemouse", TestmovemouseObjCmd, NULL, NULL);
+    Tcl_CreateObjCommand(interp, "testinjectkeyevent", TestinjectkeyeventObjCmd, NULL, NULL);
+    Tcl_CreateObjCommand(interp, "testmenubarheight", TestmenubarheightObjCmd, NULL, NULL);
     return TCL_OK;
 }
 
 /*
  *----------------------------------------------------------------------
  *
- * MenuBarHeightObjCmd --
+ * TestmenubarheightObjCmd --
  *
  *	This procedure calls [NSMenu menuBarHeight] and returns the result
  *      as an integer.  Windows can never be placed to overlap the MenuBar,
@@ -78,7 +78,7 @@ TkplatformtestInit(
  */
 
 static int
-MenuBarHeightObjCmd(
+TestmenubarheightObjCmd(
     TCL_UNUSED(void *),		/* Not used. */
     Tcl_Interp *interp,			/* Not used. */
     TCL_UNUSED(int),				/* Not used. */
@@ -124,7 +124,7 @@ TkTestLogDisplay(
 /*
  *----------------------------------------------------------------------
  *
- * PressButtonObjCmd --
+ * TestpressbuttonObjCmd --
  *
  *	This Tcl command simulates a button press at a specific screen
  *      location.  It injects NSEvents into the NSApplication event queue, as
@@ -143,7 +143,7 @@ TkTestLogDisplay(
  */
 
 static int
-PressButtonObjCmd(
+TestpressbuttonObjCmd(
     TCL_UNUSED(void *),
     Tcl_Interp *interp,
     int objc,
@@ -225,7 +225,7 @@ PressButtonObjCmd(
 /*
  *----------------------------------------------------------------------
  *
- * MoveMouseObjCmd --
+ * TestmovemouseObjCmd --
  *
  *	This Tcl command simulates a mouse motion to a specific screen
  *      location.  It injects an NSEvent into the NSApplication event queue,
@@ -242,7 +242,7 @@ PressButtonObjCmd(
  */
 
 static int
-MoveMouseObjCmd(
+TestmovemouseObjCmd(
     TCL_UNUSED(void *),
     Tcl_Interp *interp,
     int objc,
@@ -302,7 +302,7 @@ MoveMouseObjCmd(
 }
 
 static int
-InjectKeyEventObjCmd(
+TestinjectkeyeventObjCmd(
     TCL_UNUSED(void *),
     Tcl_Interp *interp,
     int objc,

diff --git a/macosx/tkMacOSXWm.c b/macosx/tkMacOSXWm.c
@@ -2977,14 +2977,15 @@ WmIconbitmapCmd(
 	TkMacOSXMakeRealWindowExist(winPtr);
     }
     if (WmSetAttribute(winPtr, TkMacOSXGetNSWindowForDrawable(winPtr->window), interp,
-	    WMATT_TITLEPATH, objv[3]) == TCL_OK) {
-	if (!len) {
-	    if (wmPtr->hints.icon_pixmap != None) {
-		Tk_FreeBitmap(winPtr->display, wmPtr->hints.icon_pixmap);
-		wmPtr->hints.icon_pixmap = None;
-	    }
-	    wmPtr->hints.flags &= ~IconPixmapHint;
+	    WMATT_TITLEPATH, objv[3]) != TCL_OK) {
+	return TCL_ERROR;
+    }
+    if (!len) {
+	if (wmPtr->hints.icon_pixmap != None) {
+	    Tk_FreeBitmap(winPtr->display, wmPtr->hints.icon_pixmap);
+	    wmPtr->hints.icon_pixmap = None;
 	}
+	wmPtr->hints.flags &= ~IconPixmapHint;
     } else {
 	pixmap = Tk_GetBitmap(interp, (Tk_Window)winPtr, str);
 	if (pixmap == None) {

diff --git a/tests/bind.test b/tests/bind.test
@@ -6931,7 +6931,7 @@ proc testKey {window event type mods} {
     }
     set save $keyInfo
     set keyInfo {}
-    set injectcmd [list injectkeyevent $type $numericKeysym]
+    set injectcmd [list testinjectkeyevent $type $numericKeysym]
     foreach {option} $mods {
 	lappend injectcmd $option
     }
@@ -7002,7 +7002,7 @@ test bind-35.2 {Can bind to function keys} -constraints {aqua} -body {
     set numericKeysym {}
     focus -force .
     event generate . <F2>
-    injectkeyevent press $numericKeysym -function
+    testinjectkeyevent press $numericKeysym -function
     vwait keyInfo
     return $keyInfo
 } -cleanup {
@@ -7032,7 +7032,7 @@ test bind-35.3 {Events agree for modifier keys} -constraints {aqua} -setup {
 	    vwait keyInfo
 	}
 	set save $keyInfo
-	injectkeyevent flagschanged $numericKeysym [lindex $event 1]
+	testinjectkeyevent flagschanged $numericKeysym [lindex $event 1]
 	if {$keyInfo == {}} {
 	    vwait keyInfo
 	}

diff --git a/tests/constraints.tcl b/tests/constraints.tcl
@@ -282,33 +282,33 @@ testConstraint nonUnixUserInteraction [expr {
 }]
 testConstraint haveDISPLAY [expr {[info exists env(DISPLAY)] && [testConstraint x11]}]
 testConstraint altDisplay  [info exists env(TK_ALT_DISPLAY)]
-testConstraint noExceed [expr {
-    ![testConstraint unix] || [catch {font actual "\{xyz"}]
-}]
+
 testConstraint deprecated [expr {![::tk::build-info no-deprecate]}]
 
 # constraint for running a test on all windowing system except aqua
 # where the test fails due to a known bug
 testConstraint aquaKnownBug [expr {[testConstraint notAqua] || [testConstraint knownBug]}]
 
 # constraints for testing facilities defined in the tktest executable...
-testConstraint testImageType [expr {"test" in [image types]}]
-testConstraint testbitmap    [llength [info commands testbitmap]]
-testConstraint testborder    [llength [info commands testborder]]
-testConstraint testcbind     [llength [info commands testcbind]]
-testConstraint testclipboard [llength [info commands testclipboard]]
-testConstraint testcolor     [llength [info commands testcolor]]
-testConstraint testcursor    [llength [info commands testcursor]]
-testConstraint testembed     [llength [info commands testembed]]
-testConstraint testfont      [llength [info commands testfont]]
-testConstraint testmakeexist [llength [info commands testmakeexist]]
-testConstraint testmenubar   [llength [info commands testmenubar]]
-testConstraint testmetrics   [llength [info commands testmetrics]]
-testConstraint testobjconfig [llength [info commands testobjconfig]]
-testConstraint testsend      [llength [info commands testsend]]
-testConstraint testtext      [llength [info commands testtext]]
-testConstraint testwinevent  [llength [info commands testwinevent]]
-testConstraint testwrapper   [llength [info commands testwrapper]]
+testConstraint testbitmap      [llength [info commands testbitmap]]
+testConstraint testborder      [llength [info commands testborder]]
+testConstraint testcbind       [llength [info commands testcbind]]
+testConstraint testclipboard   [llength [info commands testclipboard]]
+testConstraint testcolor       [llength [info commands testcolor]]
+testConstraint testcursor      [llength [info commands testcursor]]
+testConstraint testembed       [llength [info commands testembed]]
+testConstraint testfont        [llength [info commands testfont]]
+testConstraint testImageType   [expr {"test" in [image types]}]
+testConstraint testmakeexist   [llength [info commands testmakeexist]]
+testConstraint testmenubar     [llength [info commands testmenubar]]
+testConstraint testmetrics     [llength [info commands testmetrics]]
+testConstraint testmovemouse   [llength [info commands testmovemouse]]
+testConstraint testobjconfig   [llength [info commands testobjconfig]]
+testConstraint testpressbutton [llength [info commands testpressbutton]]
+testConstraint testsend        [llength [info commands testsend]]
+testConstraint testtext        [llength [info commands testtext]]
+testConstraint testwinevent    [llength [info commands testwinevent]]
+testConstraint testwrapper     [llength [info commands testwrapper]]
 
 # constraints about what sort of fonts are available
 testConstraint fonts 1
@@ -329,6 +329,31 @@ destroy .t
 if {![string match {{22 3 6 15} {31 18 [34] 15}} $x]} {
     testConstraint fonts 0
 }
+
+testConstraint withXft [expr {![catch {tk::pkgconfig get fontsystem} fs] && ($fs eq "xft")}]
+testConstraint withoutXft [expr {![testConstraint withXft]}]
+unset fs
+
+# Expected results of some tests on Linux rely on availability of the "times"
+# font. This font is generally provided when Tk uses the old X font system,
+# but not when using Xft on top of fontconfig. Specifically (old system):
+#    xlsfonts | grep times
+# may return quite some output while (new system):
+#    fc-list | grep times
+# return value is empty. That's not surprising since the two font systems are
+# separate (availability of a font in one of them does not mean it's available
+# in the other one). The following constraints are useful in this kind of
+# situation.
+testConstraint haveTimesFamilyFont [expr {
+    [string tolower [font actual {-family times} -family]] == "times"
+}]
+testConstraint haveFixedFamilyFont [expr {
+    [string tolower [font actual {-family fixed} -family]] == "fixed"
+}]
+testConstraint haveCourierFamilyFont [expr {
+    [string tolower [font actual {-family courier} -family]] == "courier"
+}]
+
 # Although unexpected, some systems may have a very limited set of fonts available.
 # The following constraints happen to evaluate to false at least on one system: the
 # Github CI runner for Linux with --disable-xft, which has exactly ONE single font
@@ -341,17 +366,14 @@ if {![string match {{22 3 6 15} {31 18 [34] 15}} $x]} {
 # tests they constrain (that is: availability of any font having the given font
 # attributes), so that these constrained tests will in fact run on all systems having
 # reasonable font dotation.
-testConstraint haveTimes12Font [expr {
-    [font actual {times 12} -size] == 12
-}]
-testConstraint haveCourier37Font [expr {
+testConstraint havePointsize37Font [expr {
     [font actual {-family courier -size 37} -size] == 37
 }]
-testConstraint haveTimes14BoldFont [expr {
+testConstraint havePointsize14BoldFont [expr {
     ([font actual {times 14 bold} -size] == 14) &&
     ([font actual {times 14 bold} -weight] eq "bold")
 }]
-testConstraint haveTimes12BoldItalicUnderlineOverstrikeFont [expr {
+testConstraint haveBoldItalicUnderlineOverstrikeFont [expr {
     ([font actual {times 12 bold italic overstrike underline} -weight] eq "bold") &&
     ([font actual {times 12 bold italic overstrike underline} -slant] eq "italic") &&
     ([font actual {times 12 bold italic overstrike underline} -underline] eq "1") &&