Tk Source Code

name: Linux
on:
  push:
    branches:
    - "main"
    - "core-8-branch"
    - "core-8-6-branch"
    - "less_tests_constraints"
    tags:
    - "core-**"
permissions:
  contents: read
defaults:
  run:
    shell: bash

      - name: Upload Documentation Distribution
        if: ${{ env.BUILD_CONFIG_ID == 'gcc' }}
        uses: actions/upload-artifact@v4
        with:
          name: Tk ${{ env.VERSION }} HTML documentation (snapshot)
          path: /tmp/dist/tk*/html
  test:
    runs-on: ubuntu-22.04
    strategy:
      matrix:
        compiler:
          - "gcc"
        config:
          - ""
          - "--disable-xft"
          - "--enable-symbols"
    steps:
      - name: Checkout Tk
        uses: actions/checkout@v4
        with:
          path: tk
      - name: Setup Environment (compiler=${{ matrix.compiler }})
        run: |
          sudo apt-get install tcl8.6-dev libxss-dev libxft-dev xvfb xfonts-75dpi xfonts-100dpi xfonts-scalable libxfont2 unifont
          mkdir "$HOME/install dir"
          touch tk/doc/man.macros tk/generic/tkStubInit.c
          echo "CFGOPT=$CFGOPT --with-tcl=/usr/lib/tcl8.6" >> $GITHUB_ENV
          echo "CC=$COMPILER" >> $GITHUB_ENV
        working-directory: "."
        env:
          CFGOPT: ${{ matrix.config }}

name: macOS
on:
  push:
    branches:
    - "main"
    - "core-8-branch"
    - "core-8-6-branch"
    - "less_tests_constraints"
    tags:
    - "core-**"
permissions:
  contents: read
env:
  ERROR_ON_FAILURES: 1
jobs:

name: Windows
on:
  push:
    branches:
    - "main"
    - "core-8-branch"
    - "core-8-6-branch"
    - "less_tests_constraints"
    tags:
    - "core-**"
permissions:
  contents: read
env:
  ERROR_ON_FAILURES: 1
jobs:

/*
 * Forward declarations of procedures defined later in this file:
 */

#if MAC_OS_X_VERSION_MAX_ALLOWED < 1080
static Tcl_ObjCmdProc DebuggerObjCmd;
#endif
static Tcl_ObjCmdProc TestpressbuttonObjCmd;
static Tcl_ObjCmdProc TestmovemouseObjCmd;
static Tcl_ObjCmdProc TestinjectkeyeventObjCmd;
static Tcl_ObjCmdProc TestmenubarheightObjCmd;


/*
 *----------------------------------------------------------------------
 *
 * TkplatformtestInit --
 *

    /*
     * Add commands for platform specific tests on MacOS here.
     */

#if MAC_OS_X_VERSION_MAX_ALLOWED < 1080
    Tcl_CreateObjCommand(interp, "debugger", DebuggerObjCmd, NULL, NULL);
#endif
    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;
}

/*
 *----------------------------------------------------------------------
 *
 * DebuggerObjCmd --

    return TCL_OK;
}
#endif

/*
 *----------------------------------------------------------------------
 *
 * TestmenubarheightObjCmd --
 *
 *	This procedure calls [NSMenu menuBarHeight] and returns the result
 *      as an integer.  Windows can never be placed to overlap the MenuBar,
 *      so tests need to be aware of its size.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestmenubarheightObjCmd(
    TCL_UNUSED(void *),		/* Not used. */
    Tcl_Interp *interp,			/* Not used. */
    TCL_UNUSED(int),				/* Not used. */
    TCL_UNUSED(Tcl_Obj *const *))		/* Not used. */
{
    static int height = 0;
    if (height == 0) {

	return True;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TestpressbuttonObjCmd --
 *
 *	This Tcl command simulates a button press at a specific screen
 *      location.  It injects NSEvents into the NSApplication event queue, as
 *      opposed to adding events to the Tcl queue as event generate would do.
 *      One application is for testing the grab command. These events have
 *      their timestamp property set to 0 as a signal indicating that they
 *      should not be ignored by [NSApp tkProcessMouseEvent].
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestpressbuttonObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    int x = 0, y = 0, i, value;
    CGPoint pt;

    [NSApp postEvent:release atStart:NO];
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TestmovemouseObjCmd --
 *
 *	This Tcl command simulates a mouse motion to a specific screen
 *      location.  It injects an NSEvent into the NSApplication event queue,
 *      as opposed to adding events to the Tcl queue as event generate would
 *      do.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestmovemouseObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    int x = 0, y = 0, i, value;
    CGPoint pt;

	clickCount:1
	pressure:0];
    [NSApp postEvent:motion atStart:NO];
    return TCL_OK;
}

static int
TestinjectkeyeventObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    static const char *const optionStrings[] = {
	"press", "release", "flagschanged", NULL};

    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
    }

	lappend keyInfo %K
	set numericKeysym %N
    }
    set keyInfo {}
    set numericKeysym {}
    focus -force .
    event generate . <F2>
    testinjectkeyevent press $numericKeysym -function
    vwait keyInfo
    return $keyInfo
} -cleanup {
} -result {F2 F2}

test bind-35.3 {Events agree for modifier keys} -constraints {aqua} -setup {
} -body {

    } {
	set keyInfo {}
	event generate . [lindex $event 0]
	if {$keyInfo == {}} {
	    vwait keyInfo
	}
	set save $keyInfo
	testinjectkeyevent flagschanged $numericKeysym [lindex $event 1]
	if {$keyInfo == {}} {
	    vwait keyInfo
	}
	if {$save != $keyInfo} {
	    return "$save != $keyInfo"
	}
    }

testConstraint userInteraction 0
testConstraint nonUnixUserInteraction [expr {
    [testConstraint userInteraction] ||
    ([testConstraint unix] && [testConstraint notAqua])
}]
testConstraint haveDISPLAY [expr {[info exists env(DISPLAY)] && [testConstraint x11]}]
testConstraint altDisplay  [info exists env(TK_ALT_DISPLAY)]



# 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 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 testOldImageType [expr {"oldtest" in [image types]}]
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
destroy .e
entry .e -width 0 -font {Helvetica -12} -bd 1 -highlightthickness 1
.e insert end a.bcd
if {([winfo reqwidth .e] != 37) || ([winfo reqheight .e] != 20)} {
    testConstraint fonts 0
}
destroy .e
destroy .t
text .t -width 80 -height 20 -font {Times -14} -bd 1
pack .t
.t insert end "This is\na dot."
update
set x [list [.t bbox 1.3] [.t bbox 2.5]]
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
# ([font families] returns a single element: "fixed"), for which [font actual]
# returns:
#    -family fixed -size 9 -weight normal -slant roman -underline 0
# and [font metrics] returns:
#    -ascent 11 -descent 2 -linespace 13 -fixed 1
# The following constraints are hence tailored to check exactly what is needed in the
# 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 havePointsize37Font [expr {



    [font actual {-family courier -size 37} -size] == 37
}]
testConstraint havePointsize14BoldFont [expr {
    ([font actual {times 14 bold} -size] == 14) &&
    ([font actual {times 14 bold} -weight] eq "bold")
}]
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") &&
    ([font actual {times 12 bold italic overstrike underline} -overstrike] eq "1")
}]
set fixedFont {Courier 12}   ; # warning: must be consistent with the files using the constraint below!
set bigFont   {Helvetica 24} ; # ditto

namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands

# Some tests require support for 4-byte UTF-8 sequences
testConstraint fullutf [expr {[format %c 0x010000] != "\uFFFD"}]



set defaultfontlist [font names]

proc getnondefaultfonts {} {
    global defaultfontlist
    set nondeffonts [list ]
    foreach afont [font names] {
        if {$afont ni $defaultfontlist} {

test font-4.5 {font command: actual: displayof specified, so skip to next} -body {
    lindex [font actual xyz -displayof .] 0
} -result {-family}
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} -body {
    # (tkfont == NULL)
    font actual "\{xyz"
} -returnCodes error -result "font \"{xyz\" doesn't 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 {haveTimesFamilyFont} -body {
    # (objc > 3) so objPtr = objv[3 + skip]
    string tolower [font actual {-family times} -family]
} -result {times}
test font-4.10 {font command: actual} -constraints win -body {
    # (objc > 3) so objPtr = objv[3 + skip]
    font actual {-family times} -family
} -result {Times New Roman}

    # (objc - skip != 2) when skip == 0
    font families xyz
} -returnCodes error -result {wrong # args: should be "font families ?-displayof window?"}
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 haveTimesFamilyFont -body {
    # TkpGetFontFamilies()
    regexp -nocase times [font families]
} -result 1


test font-9.1 {font command: measure: arguments} -body {
    # (skip < 0)
    expr {[font measure xyz -displayof] > 0}
} -returnCodes ok -result 1
test font-9.2 {font command: measure: arguments} -body {
    # (objc - skip != 4)
    font measure
} -returnCodes error -result {wrong # args: should be "font measure font ?-displayof window? text"}
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} -body {
    # (tkfont == NULL)
    font measure "\{xyz" abc
} -returnCodes error -result "font \"{xyz\" doesn't exist"
test font-9.5 {font command: measure} -body {
    # Tk_TextWidth()
    expr {[font measure $fixed "abcdefg"] == [font measure $fixed "a"]*7 }
} -result 1

    # (objc - skip) > 4) when skip == 0
    font metrics xyz abc def
} -returnCodes error -result {wrong # args: should be "font metrics font ?-displayof window? ?option?"}
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, -linespace, or -fixed}
test font-10.6 {font command: metrics: bad font} -body {
    # (tkfont == NULL)
    font metrics "\{xyz"
} -returnCodes error -result "font \"{xyz\" doesn't exist"
test font-10.7 {font command: metrics: get all metrics} -setup {
    catch {unset a}
} -body {
    # (objc == 3)

    update
} -body {
    # (fontPtr == NULL)
    .t.f config -font {xxx yyy zzz}
} -cleanup {
	destroy .t.f
} -returnCodes error -result {expected integer but got "yyy"}
test font-15.10 {Tk_AllocFontFromObj procedure: no match} -body {
    # (ParseFontNameObj() != TCL_OK)
    font actual "\{xyz"
} -returnCodes error -result "font \"{xyz\" doesn't exist"
test font-15.11 {Tk_AllocFontFromObj procedure: get attribute font} -body {
    # not (ParseFontNameObj() != TCL_OK)
    lindex [font actual {plan 9}] 0
} -result {-family}

    if {[string match lucida*bright $x]} {
		psfontname "{lucida bright} 10"
    } else {
		set x {LucidaBright}
    }
} -result {LucidaBright}
test font-21.6 {Tk_PostscriptFontName procedure: spaces} -constraints {
    x11
} -body {
    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 {
    set name {avantgarde 12 roman normal}
    if {[font actual {avantgarde 12 roman normal} -family] == "avantgarde"} {
        set x [psfontname avantgarde 12 roman normal]
    } else {

} -result [font actual {times 0} -family]
test font-38.5 {ParseFontNameObj procedure: begins with *} -body {
    lindex [font actual *-times-xyz-*-*-*-*-*-*-*-*-*-*-*] 1
} -result [font actual {times 0} -family]
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} -body {
    font actual "\{xyz"
} -returnCodes error -result "font \"{xyz\" doesn't exist"
test font-38.8 {ParseFontNameObj procedure: arguments} -body {
    font actual ""
} -returnCodes error -result {font "" doesn't exist}
test font-38.9 {ParseFontNameObj procedure: arguments} -body {
    font actual {times 20 xyz xyz}
} -returnCodes error -result {unknown font style "xyz"}
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 haveBoldItalicUnderlineOverstrikeFont
} -body {
    lrange [font actual {times 12 bold italic overstrike underline}] 4 end
} -result {-weight bold -slant italic -underline 1 -overstrike 1}
test font-38.12 {ParseFontNameObj procedure: stylelist error} -body {
    font actual {times 12 bold xyz}
} -returnCodes error -result {unknown font style "xyz"}
test font-38.13 "ParseFontNameObj: options with hyphenated family: bug #2791352" -body {

} -body {
    set oldsize [expr {-(-12.0 / $oldscale)}]
    tk scaling 0.5
    expr {round([font actual {times -12} -size] / $oldscale * 0.5) - round($oldsize) == 0}
} -cleanup {
    tk scaling $oldscale
} -result 1
test font-44.2 {TkFontGetPoints: size >= 0} -setup {
    set oldscale [tk scaling]
} -body {
    set oldSize [font actual {times 12} -size]
    tk scaling 0.5
    expr {[font actual {times 12} -size] == $oldSize}
} -cleanup {
    tk scaling $oldscale
} -result 1


test font-45.1 {TkFontGetAliasList: no match} -body {
    font actual {snarky 10} -family
} -result [font actual {-size 10} -family]
test font-45.2 {TkFontGetAliasList: match} -constraints win -body {
    font actual {times 10} -family
} -result {Times New Roman}
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
    } else {
        set res [expr {[font actual {{times new roman} 10} -family] eq \
                       [font actual {times 10} -family]} ]
    }

    }
    then {
        Click ok
    }
    expr {$::testfont ne {}}
} -result 1

test fontchooser-4.4 {fontchooser -font} -constraints {scriptImpl havePointsize14BoldFont} -body {
    start {
        tk::fontchooser::Configure -command ApplyFont -font {times 14 bold}
        tk::fontchooser::Show
    }
    then {
        Click ok
    }

test frame-2.14 {toplevel configuration options} -setup {
    deleteWindows
} -body {
    toplevel .t -width 200 -height 100 -visual who_knows?
} -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}




test frame-2.15 {toplevel configuration options} -constraints haveDISPLAY -setup {
    deleteWindows
} -body {
    toplevel .t -width 200 -height 100 -screen $env(DISPLAY)
    wm geometry .t +0+0
    .t configure -screen
} -cleanup {
    deleteWindows
} -result [list -screen screen Screen {} $env(DISPLAY)]
test frame-2.16 {toplevel configuration options} -constraints haveDISPLAY -setup {
    deleteWindows
} -body {
    toplevel .t -width 200 -height 100 -screen $env(DISPLAY)
    wm geometry .t +0+0
    .t configure -screen another
} -returnCodes error -cleanup {
    deleteWindows

# All rights reserved.

package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test

# The macOS test module includes the testpressbutton command to simulate a
# mouse button press event by injecting events into the NSApplication
# event queue.  On other platforms there is 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.) on platforms other than macOS.



test grab-1.1 {Tk_GrabObjCmd} -body {
    grab
} -returnCodes error -result {wrong # args: should be "grab ?-global? window" or "grab option ?arg ...?"}
test grab-1.2 {Tk_GrabObjCmd} -body {
    rename grab grabTest1.2
    grabTest1.2
} -cleanup {

    grab set -global .
    list [grab current .] [grab status .]
} -cleanup {
    grab release .
} -result {. global}

test grab-6.1 {local grab on child window} -constraints {
    testpressbutton
} -body {
    wm geometry . 100x200+200+100
    set result {}
    frame .f -background red -padx 10 -pady 10 -height 100 -width 80
    bind . <Button-1> {lappend result "outside"}
    bind .f <Button-1> {lappend result "inside"}
    pack .f
    update idletasks
    testpressbutton 250 150
    update
    lappend result ":"
    testpressbutton 250 250
    update
    lappend result ":"
    grab set .f
    testpressbutton 250 150
    update
    lappend result ":"
    testpressbutton 250 250
    update
    return $result
} -cleanup {
    grab release .f
} -result {inside outside : outside : inside outside :}

cleanupTests
return

eval tcltest::configure $argv
tcltest::loadTestedCommands
imageInit

# find the earth.gif file for use in these tests (tests 2.*)
set earthPhotoFile [file join [file dirname [info script]] earth.gif]
testConstraint hasEarthPhoto [file exists $earthPhotoFile]



test menu-1.1 {Tk_MenuCmd procedure} -body {
    menu
} -returnCodes error -result {wrong # args: should be "menu pathName ?-option value ...?"}
test menu-1.2 {Tk_MenuCmd procedure} -body {
    menu bogus
} -returnCodes error -result {bad window path name "bogus"}

    destroy .t.menubar.select.chain
    .t.menubar.select delete 1
} -cleanup {
    destroy .t
} -result {}

test menu-40.1 {Use-after-free if menu destroyed while posted - bug 09a11fb1228f} -setup {
} -constraints {testpressbutton} -body {
    set done false
    event generate {} <Motion> -x 100 -y 100
    toplevel .t
    menu .t.m
    .t.m add command -command {puts Marco} -label Marco
    .t.m add command -command {puts Polo} -label Polo
    after 1000 {.t.m post 500 500}
    after 2000 {destroy .t}
    after 2500 {testpressbutton 530 510}
    after 3000 {set done true}
    tkwait variable done
}

test menu-40.2 {Use-after-free if menu destroyed while posted - bug 09a11fb1228f} -setup {
} -constraints {testmovemouse} -body {
    set done false
    event generate {} <Motion> -x 100 -y 100
    toplevel .t
    menu .t.m
    .t.m add command -command {puts Marco} -label Marco
    .t.m add command -command {puts Polo} -label Polo
    after 1000 {.t.m post 500 500}
    after 2000 {testmovemouse 530 510}
    after 3000 {destroy .t}
    after 3500 {testmovemouse 530 530}
    after 4000 testpressbutton 530 530
    after 4500 {set done true}
    tkwait variable done
    testpressbutton 530 510
}

# cleanup
imageFinish
deleteWindows
cleanupTests
return

# Local variables:
# mode: tcl
# End:

    dobg {selection get ERROR}
} -cleanup {
    cleanupbg
} -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
} -setup {
    setup
    setupbg
} -body {
    set selValue $longValue
    set selInfo ""
    selection handle .f1 {errIncrHandler STRING}

} -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.
# On macOS, however, there is no way to make the window overlap the menubar.
if {[tk windowingsystem] eq "aqua"} {
    set minY [expr [testmenubarheight] + 1]
} else {
    set minY 0
}
test text-14.19 {ConfigureText procedure} -setup {
    toplevel .top
    text .top.t -font {Courier -12} -borderwidth 2 -highlightthickness 2
} -body {

test combobox-3 "Read postoffset value dynamically from current style" -body {
    ttk::combobox .cb -values [list a b c] -style "DerivedStyle.TCombobox"
    pack .cb -expand true -fill both
    update idletasks
    ttk::style configure DerivedStyle.TCombobox -postoffset [list 25 0 0 0]
    if {[tk windowingsystem] == "aqua"} {
	after 500 {
	    testpressbutton [expr {[winfo rootx .cb] + 25}] [expr {[winfo rooty .cb] + 25}]
	}
    }
    ttk::combobox::Post .cb
    expr {[winfo rootx .cb.popdown] - [winfo rootx .cb]}
} -result 25 -cleanup {
    destroy .cb
}

proc colorsFree {w {red 31} {green 245} {blue 192}} {
    set vals [winfo rgb $w [format #%02x%02x%02x $red $green $blue]]
    expr ([lindex $vals 0]/256 == $red) && ([lindex $vals 1]/256 == $green) \
	    && ([lindex $vals 2]/256 == $blue)
}



test unixEmbed-1.1 {TkpUseWindow procedure, bad window identifier} -constraints {
    unix
} -setup {
    deleteWindows
} -body {
    toplevel .t -use xyz
} -returnCodes error -result {expected integer but got "xyz"}

    focus -force .t
    focus -force .embed
    focus
} -cleanup {
    deleteWindows
} -result .embed
test unixEmbed-11.2 {mouse coordinates in embedded toplevels} -constraints {
    unix testpressbutton
} -setup {
    deleteWindows
} -body {
    set result {}
    toplevel .main
    update
    frame .main.f -container 1 -width 200 -height 200

    pack .embed.b -padx 30 -pady 30
    update
    focus -force .main
    update
    set x [expr {[winfo rootx .main.b] + [winfo width .main.b]/2}]
    set y [expr {[winfo rooty .main.b] + [winfo height .main.b]/2}]
    lappend result [winfo containing $x $y]
    testpressbutton $x $y
    update
    set x [expr {[winfo rootx .embed.b] + [winfo width .embed.b]/2}]
    set y [expr {[winfo rooty .embed.b] + [winfo height .embed.b]/2}]
    lappend result [winfo containing $x $y]
    testpressbutton $x $y
    update
    set result
} -cleanup {
    deleteWindows
} -result {.main.b {pushed .main.b} .embed.b {pushed .embed.b}}


# cleanup
deleteWindows
cleanupbg
cleanupTests
return

# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.

package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands




if {[tk windowingsystem] eq "x11"} {
    set withXft [expr {![catch {tk::pkgconfig get fontsystem} fs] && ($fs eq "xft")}]
    if {$withXft} {
        set fontsystemcmd [auto_execok fc-list]
    } else {
        set fontsystemcmd [auto_execok xlsfonts]
    }
}
foreach {constraint font} {
    hasArial      arial
    hasCourierNew "courier new"
    hasTimesNew   "times new roman"
} {
    testConstraint $constraint 0
    if {([tk windowingsystem] eq "x11") && [llength $fontsystemcmd]} {
	if {$withXft} {
	    if {[exec $fontsystemcmd $font family] ne ""} {
		testConstraint $constraint 1
	    }
	} else {
	    # With the old font system, the constraint is true by default,
	    # except on the mac with XQuartz
	    testConstraint $constraint [expr {!(($tcl_platform(os) eq "Darwin") \
					     && ([tk windowingsystem] eq "x11"))}]
	    if {![catch {eval exec $fontsystemcmd [list *-$font-*]} res]
		    && ![string match *unmatched* $res]} {
		# Newer Unix systems have more default fonts installed,
		# so we can't rely on fallbacks for fonts to need to
		# fall back on anything.
		testConstraint $constraint 0
	    }
	}


    }
}
unset -nocomplain withXft

catch {destroy .b}
toplevel .b
wm geom .b +0+0
update idletasks

# Font should be fixed width and have chars missing below char 32, so can
# test control char expansion and missing character code.

set courier {Courier -10}
set cx [font measure $courier 0]

label .b.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left -text "0" -font TkFixedFont
pack .b.l
canvas .b.c -closeenough 0

set t [.b.c create text 0 0 -anchor nw -just left -font $courier]
pack .b.c
update

set ax [winfo reqwidth .b.l]
set ay [winfo reqheight .b.l]
proc getsize {} {
    update
    return "[winfo reqwidth .b.l] [winfo reqheight .b.l]"
}

test unixfont-1.1 {TkpGetNativeFont procedure: not native} {x11} {
    list [catch {font measure {} xyz} msg] $msg
} {1 {font "" doesn't exist}}
test unixfont-1.2 {TkpGetNativeFont procedure: native} {x11 haveFixedFamilyFont} {
    font measure fixed 0
} 6

test unixfont-2.1 {TkpGetFontFromAttributes procedure: no family} x11 {
    font actual {-size 10}
    set x {}
} {}
test unixfont-2.2 {TkpGetFontFromAttributes procedure: Times relatives} \
	{x11 hasTimesNew} {
    set x {}
    lappend x [lindex [font actual {-family "Times New Roman"}] 1]
    lappend x [lindex [font actual {-family "New York"}] 1]
    lappend x [lindex [font actual {-family "Times"}] 1]
} {times times times}
test unixfont-2.3 {TkpGetFontFromAttributes procedure: Courier relatives} \
	{x11 hasCourierNew} {
    set x {}
    lappend x [lindex [font actual {-family "Courier New"}] 1]
    lappend x [lindex [font actual {-family "Monaco"}] 1]
    lappend x [lindex [font actual {-family "Courier"}] 1]
} {courier courier courier}
test unixfont-2.4 {TkpGetFontFromAttributes procedure: Helvetica relatives} \
	{x11 hasArial} {
    set x {}
    lappend x [lindex [font actual {-family "Arial"}] 1]
    lappend x [lindex [font actual {-family "Geneva"}] 1]
    lappend x [lindex [font actual {-family "Helvetica"}] 1]
} {helvetica helvetica helvetica}
test unixfont-2.5 {TkpGetFontFromAttributes procedure: fallback} x11 {
    font actual {-xyz-xyz-*-*-*-*-*-*-*-*-*-*-*-*}
    set x {}
} {}
test unixfont-2.6 {TkpGetFontFromAttributes: fallback to fixed family} {x11 haveFixedFamilyFont} {
    lindex [font actual {-family fixed -size 10}] 1
} {fixed}
test unixfont-2.7 {TkpGetFontFromAttributes: fixed family not available!} x11 {
    # no test available
} {}
test unixfont-2.8 {TkpGetFontFromAttributes: loop over returned font names} {x11 haveFixedFamilyFont} {
    lindex [font actual {-family fixed -size 31}] 1
} {fixed}
test unixfont-2.9 {TkpGetFontFromAttributes: reject adobe courier if possible} {x11 haveCourierFamilyFont} {
    lindex [font actual {-family courier}] 1
} {courier}
test unixfont-2.10 {TkpGetFontFromAttributes: scalable font found} {x11 havePointsize37Font} {
    lindex [font actual {-family courier -size 37}] 3
} 37
test unixfont-2.11 {TkpGetFontFromAttributes: font cannot be loaded} x11 {
    # On Linux, XListFonts() was returning names for fonts that do not
    # actually exist, causing the subsequent XLoadQueryFont() to fail
    # unexpectedly.  Now falls back to another font if that happens.

    .b.l config -text "000000 00000"
    getsize
} "[expr $ax*6] [expr $ay*2]"
test unixfont-5.7 {Tk_MeasureChars procedure: already saw space in line} x11 {
    .b.l config -text "000000     00000"
    getsize
} "[expr $ax*6] [expr $ay*2]"
test unixfont-5.8 {Tk_MeasureChars procedure: internal spaces significant} {x11} {
    .b.l config -text "00  000     00000"
    getsize
} "[expr $ax*7] [expr $ay*2]"
test unixfont-5.9 {Tk_MeasureChars procedure: TK_PARTIAL_OK} {x11} {
    .b.c dchars $t 0 end
    .b.c insert $t 0 "0000"
    .b.c index $t @[expr int($ax*2.5)],1
} 2
test unixfont-5.10 {Tk_MeasureChars procedure: TK_AT_LEAST_ONE} x11 {
    .b.l config -text "000000000000"
    getsize
} "[expr $ax*10] [expr $ay*2]"
test unixfont-5.11 {Tk_MeasureChars: TK_AT_LEAST_ONE + not even one char fit!} x11 {
    set a [.b.l cget -wrap]
    .b.l config -text "000000" -wrap 1
    set x [getsize]
    .b.l config -wrap $a
    set x
} "$ax [expr $ay*6]"
test unixfont-5.12 {Tk_MeasureChars procedure: include eol spaces} {x11} {
    .b.l config -text "000   \n000"
    getsize
} "[expr $ax*6] [expr $ay*2]"

test unixfont-6.1 {Tk_DrawChars procedure: loop test} x11 {
    .b.l config -text "a"
    update

    # check that font actual returns the correct attributes.
    # the values of those attributes are system dependent.
    array set fontArray [font actual a12biluc]
    set result [lsort [array names fontArray]]
    catch {unset fontArray}
    set result
} {-family -overstrike -size -slant -underline -weight}
test unixfont-8.4 {InitFont procedure: classify characters} {x11 nonPortable} {
# Constrained by nonPortable because this test highly relies on fonts availability.
# - without Xft, I couldn't find any font featuring a glyph of 6 charwidths
#   for character \u4000. The 'unifont' package provides this glyph but the
#   width of \u4000 is only 2 character widths (which seems visually fine).
# - with Xft the problem is identical for \u4000, and moreover the width
#   of, say, \002 depends on which fonts are installed.
    set x 0
    incr x [font measure $courier "\u4000"]   ;# 6
    incr x [font measure $courier "\002"]   ;# 4
    incr x [font measure $courier "\012"]   ;# 2
    incr x [font measure $courier "\101"]   ;# 1
    set x
} [expr $cx*13]
test unixfont-8.5 {InitFont procedure: setup widths of normal chars} x11 {
    font metrics $courier -fixed
} 1
test unixfont-8.6 {InitFont procedure: setup widths of special chars} {x11 withoutXft} {
# Constrained by withoutXft because with Xft the width of, say, \002 depends
# on which fonts are installed and get substituted by Tk.
    set x 0
    incr x [font measure $courier "\001"]   ;# 4
    incr x [font measure $courier "\002"]   ;# 4
    incr x [font measure $courier "\012"]   ;# 2
    set x
} [expr $cx*10]
test unixfont-8.7 {InitFont procedure: XA_UNDERLINE_POSITION} x11 {

    set x {}
} {}
test unixfont-8.11 {InitFont procedure: XA_UNDERLINE_POSITION was 0} x11 {
    catch {font actual -adobe-courier-bold-i-normal--0-0-0-0-m-0-iso8859-1}
    set x {}
} {}

test unixfont-9.1 {2 chars substituted in inserted text} {x11 withoutXft} {
# Constrained by withoutXft because with Xft the width of \a (aka \007 the
# bell character) depends on which fonts are installed and get substituted
# by Tk.
    .b.c dchars $t 0 end
    .b.c insert $t 0 "0\a0"
    set x {}
    lappend x [.b.c index $t @[expr $ax*0],0]
    lappend x [.b.c index $t @[expr $ax*1],0]
    lappend x [.b.c index $t @[expr $ax*2],0]
    lappend x [.b.c index $t @[expr $ax*3],0]
} {0 1 1 2}
test unixfont-9.2 {4 chars substituted in inserted text} {x11 withoutXft} {
# Constrained by withoutXft because with Xft the width of \001 depends
# on which fonts are installed and get substituted by Tk.
    .b.c dchars $t 0 end
    .b.c insert $t 0 "0\0010"
    set x {}
    lappend x [.b.c index $t @[expr $ax*0],0]
    lappend x [.b.c index $t @[expr $ax*1],0]
    lappend x [.b.c index $t @[expr $ax*2],0]
    lappend x [.b.c index $t @[expr $ax*3],0]

# 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
# height of the menubar (normally 23 pixels) and an x coordinate larger than the
# width of the dock, if it happens to be on the left.

if {[tk windowingsystem] eq "aqua"} {
    set mb [expr [testmenubarheight] + 1]
    set X  100
    set Y0 $mb
    set Y2 [expr $mb + 2]
    set Y5 [expr $mb + 5]
} else {
    set X  20
    set Y0 0