Merge branch less_tests_constraints. Summary of changes:

- Work on failsOnUbuntu / failsOnXQuarz constraints to remove them as much as possible. Add completely specific constraints instead in some cases.
- Eradicate constraint noExceed
- Factorize definition of some constraints (e.g. 'pressbutton', 'movemouse'), and rename some constraints to test* to conform to other test constraint names
- (Linux) Add font packages in the install step before running the test suite at CI, so that the CI environment can count on those fonts to be available
- Remove warnings when DEBUG_FONTSEL is defined
- Modernize code ("eval destroy" -> "destroy {*}")

Author: fvogelnew1

.github/workflows/linux-build.yml

@@ -147,7 +147,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

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,

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
 	}

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") &&

tests/font.test

@@ -14,8 +14,6 @@ tcltest::loadTestedCommands
 # Some tests require support for 4-byte UTF-8 sequences
 testConstraint fullutf [expr {[format %c 0x010000] != "\uFFFD"}]
 testConstraint utfcompat [expr {([string length "\U10000"] == 2) && [package vsatisfies [package provide Tcl] 8]}]
-testConstraint failsOnUbuntu [expr {![info exists ::env(CI)] || ![string match Linux $::tcl_platform(os)]}]
-
 set defaultfontlist [font names]
 
 proc getnondefaultfonts {} {
@@ -130,15 +128,15 @@ test font-4.6 {font command: actual: arguments} -body {
     # (objc - skip > 4) when skip == 2
     font actual xyz -displayof . abc def
 } -returnCodes error -result {wrong # args: should be "font actual font ?-displayof window? ?-option? ?--? ?char?"}
-test font-4.7 {font command: actual: arguments} -constraints noExceed -body {
+test font-4.7 {font command: actual: arguments} -body {
     # (tkfont == NULL)
     font actual "\{xyz"
 } -returnCodes error -result "font \"{xyz\" does not exist"
 test font-4.8 {font command: actual: all attributes} -body {
     # not (objc > 3) so objPtr = NULL
     lindex [font actual {-family times}] 0
 } -result {-family}
-test font-4.9 {font command: actual} -constraints {unix noExceed failsOnUbuntu} -body {
+test font-4.9 {font command: actual} -constraints {haveTimesFamilyFont} -body {
     # (objc > 3) so objPtr = objv[3 + skip]
     string tolower [font actual {-family times} -family]
 } -result {times}
@@ -384,7 +382,7 @@ test font-8.3 {font command: families: arguments} -body {
     # (objc - skip != 2) when skip == 2
     font families -displayof . xyz
 } -returnCodes error -result {wrong # args: should be "font families ?-displayof window?"}
-test font-8.4 {font command: families} -constraints failsOnUbuntu -body {
+test font-8.4 {font command: families} -constraints haveTimesFamilyFont -body {
     # TkpGetFontFamilies()
     regexp -nocase times [font families]
 } -result 1
@@ -402,7 +400,7 @@ test font-9.3 {font command: measure: arguments} -body {
     # (objc - skip != 4)
     font measure xyz abc def
 } -returnCodes error -result {wrong # args: should be "font measure font ?-displayof window? text"}
-test font-9.4 {font command: measure: arguments} -constraints noExceed -body {
+test font-9.4 {font command: measure: arguments} -body {
     # (tkfont == NULL)
     font measure "\{xyz" abc
 } -returnCodes error -result "font \"{xyz\" does not exist"
@@ -440,7 +438,7 @@ test font-10.5 {font command: metrics: arguments} -body {
     # (objc - skip) > 4) when skip == 2
     font metrics xyz -displayof . abc
 } -returnCodes error -result {bad metric "abc": must be -ascent, -descent, -fixed, or -linespace}
-test font-10.6 {font command: metrics: bad font} -constraints noExceed -body {
+test font-10.6 {font command: metrics: bad font} -body {
     # (tkfont == NULL)
     font metrics "\{xyz"
 } -returnCodes error -result "font \"{xyz\" does not exist"
@@ -704,7 +702,7 @@ test font-15.9 {Tk_AllocFontFromObj procedure: get attribute font} -setup {
 } -cleanup {
 	destroy .t.f
 } -returnCodes error -result {expected integer but got "yyy"}
-test font-15.10 {Tk_AllocFontFromObj procedure: no match} -constraints noExceed -body {
+test font-15.10 {Tk_AllocFontFromObj procedure: no match} -body {
     # (ParseFontNameObj() != TCL_OK)
     font actual "\{xyz"
 } -returnCodes error -result "font \"{xyz\" does not exist"
@@ -936,11 +934,15 @@ test font-21.5 {Tk_PostscriptFontName procedure: spaces} -constraints {
     }
 } -result {LucidaBright}
 test font-21.6 {Tk_PostscriptFontName procedure: spaces} -constraints {
-	x11 failsOnUbuntu
+    x11
 } -body {
-    psfontname "{new century schoolbook} 10"
+    set name {{new century schoolbook} 10}
+    if {[font actual {{new century schoolbook} 10} -family] == "new century schoolbook"} {
+        set x [psfontname "{new century schoolbook} 10"]
+    } else {
+        set x NewCenturySchlbk-Roman
+    }
 } -result {NewCenturySchlbk-Roman}
-
 test font-21.7 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
     unix
 } -body {
@@ -2252,10 +2254,10 @@ test font-38.5 {ParseFontNameObj procedure: begins with *} -body {
 test font-38.6 {ParseFontNameObj procedure: begins with *} -body {
     font actual *-times-xyz -family
 } -result [font actual {times 0} -family]
-test font-38.7 {ParseFontNameObj procedure: arguments} -constraints noExceed -body {
+test font-38.7 {ParseFontNameObj procedure: arguments} -body {
     font actual "\{xyz"
 } -returnCodes error -result "font \"{xyz\" does not exist"
-test font-38.8 {ParseFontNameObj procedure: arguments} -constraints noExceed -body {
+test font-38.8 {ParseFontNameObj procedure: arguments} -body {
     font actual ""
 } -returnCodes error -result {font "" does not exist}
 test font-38.9 {ParseFontNameObj procedure: arguments} -body {
@@ -2265,7 +2267,7 @@ test font-38.10 {ParseFontNameObj procedure: arguments} -body {
     font actual {times xyz xyz}
 } -returnCodes error -result {expected integer but got "xyz"}
 test font-38.11 {ParseFontNameObj procedure: stylelist loop} -constraints {
-    unixOrWin haveTimes12BoldItalicUnderlineOverstrikeFont
+    unixOrWin haveBoldItalicUnderlineOverstrikeFont
 } -body {
     lrange [font actual {times 12 bold italic overstrike underline}] 4 end
 } -result {-weight bold -slant italic -underline 1 -overstrike 1}
@@ -2356,14 +2358,15 @@ test font-44.1 {TkFontGetPixels: size < 0}  -setup {
 } -cleanup {
     tk scaling $oldscale
 } -result 26
-test font-44.2 {TkFontGetPoints: size >= 0} -constraints {noExceed haveTimes12Font} -setup {
+test font-44.2 {TkFontGetPoints: size >= 0} -setup {
     set oldscale [tk scaling]
 } -body {
+    set oldSize [font actual {times 12} -size]
     tk scaling 0.5
-    font actual {times 12} -size
+    expr {[font actual {times 12} -size] == $oldSize}
 } -cleanup {
     tk scaling $oldscale
-} -result 12
+} -result 1
 test font-44.3 {font create with display scaling not 100% - bug 8162e9b7a9} -body {
     set font1 TkDefaultFont
     set font2 [font create Font2 {*}[font actual $font1]]
@@ -2379,7 +2382,7 @@ test font-45.1 {TkFontGetAliasList: no match} -body {
 test font-45.2 {TkFontGetAliasList: match} -constraints win -body {
     font actual {times 10} -family
 } -result {times}
-test font-45.3 {TkFontGetAliasList: match} -constraints {noExceed failsOnUbuntu} -body {
+test font-45.3 {TkFontGetAliasList: match} -constraints haveTimesFamilyFont -body {
     if {[font actual {{times new roman} 10} -family] eq "Times New Roman"} {
 	# avoid test failure on systems that have a real "times new roman" font
 	set res 1

tests/fontchooser.test

@@ -179,7 +179,7 @@ test fontchooser-4.3 {fontchooser -font} -constraints scriptImpl -body {
     expr {$::testfont ne {}}
 } -result 1
 
-test fontchooser-4.4 {fontchooser -font} -constraints {scriptImpl haveTimes14BoldFont} -body {
+test fontchooser-4.4 {fontchooser -font} -constraints {scriptImpl havePointsize14BoldFont} -body {
     start {
 	tk::fontchooser::Configure -command ApplyFont -font {times 14 bold}
 	tk::fontchooser::Show

tests/frame.test

@@ -435,7 +435,7 @@ set expectedScreen ""
 if {[tcltest::testConstraint haveDISPLAY]} {
     set expectedScreen [list -screen screen Screen {} $env(DISPLAY)]
 }
-test frame-2.15 {toplevel configuration options} -constraints {x11 haveDISPLAY} -setup {
+test frame-2.15 {toplevel configuration options} -constraints haveDISPLAY -setup {
     deleteWindows
 } -body {
     toplevel .t -width 200 -height 100 -screen $env(DISPLAY)
@@ -444,7 +444,7 @@ test frame-2.15 {toplevel configuration options} -constraints {x11 haveDISPLAY}
 } -cleanup {
     deleteWindows
 } -result $expectedScreen
-test frame-2.16 {toplevel configuration options} -constraints {x11 haveDISPLAY} -setup {
+test frame-2.16 {toplevel configuration options} -constraints haveDISPLAY -setup {
     deleteWindows
 } -body {
     toplevel .t -width 200 -height 100 -screen $env(DISPLAY)