Tk Source Code

        uses: actions/checkout@v4
        with:
          repository: tcltk/tcl
          ref: main
          path: tcl
      - name: Setup Environment (compiler=${{ matrix.compiler }})
        run: |
          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.config }}

  build:
    runs-on: ubuntu-22.04
    strategy:
      matrix:
        compiler:
          - "gcc"
          - "clang"
        config:
          - ""
          - "CFLAGS=-DTK_NO_DEPRECATED=1"
          - "--disable-shared"
          - "--disable-xft"
          - "--disable-xss"
          - "--enable-symbols"
    steps:

          touch tk/doc/man.macros tk/generic/tkStubInit.c
          echo "CFGOPT=$CFGOPT" >> $GITHUB_ENV
          echo "CC=$COMPILER" >> $GITHUB_ENV
          echo "TOOL_DIR=$(cd tcl/tools;pwd)" >> $GITHUB_ENV
          echo "BUILD_CONFIG_ID=$OPTS" >> $GITHUB_ENV
        working-directory: "."
        env:
          CFGOPT: ${{ matrix.config }}
          COMPILER: ${{ matrix.compiler }}
          OPTS: ${{ matrix.compiler }}${{ matrix.config }}
      - name: Configure and Build Tcl
        run: |
          ./configure $CFGOPT "--prefix=$HOME/install dir" || {
            cat config.log
            echo "::warning::Failure during Tcl Configure"
            exit 1
          }
          make all install  || {
            echo "::warning::Failure during Tcl Build"
            exit 1
          }
          echo "TCL_CONFIG_PATH=`pwd`" >> $GITHUB_ENV
        working-directory: tcl/unix
      - name: Configure (opts=${{ matrix.config }})
        run: |
          ./configure $CFGOPT --with-tcl=$TCL_CONFIG_PATH "--prefix=$HOME/install dir" || {
            cat config.log
            echo "::error::Failure during Configure"
            exit 1
          }
      - name: Build

          }
  test:
    runs-on: ubuntu-22.04
    strategy:
      matrix:
        compiler:
          - "gcc"
        config:
          - ""
          - "--disable-xft"
          - "--enable-symbols"
    steps:
      - name: Checkout
        uses: actions/checkout@v4
        with:
          path: tk
      - name: Checkout Tcl
        uses: actions/checkout@v4
        with:
          repository: tcltk/tcl
          ref: core-8-branch
          path: tcl
      - name: Setup Environment (compiler=${{ matrix.compiler }})
        run: |
          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.config }}
          COMPILER: ${{ matrix.compiler }}
      - name: Configure and Build Tcl
        run: |
          ./configure $CFGOPT "--prefix=$HOME/install dir" || {
            cat config.log
            echo "::warning::Failure during Tcl Configure"
            exit 1
          }
          make all install  || {
            echo "::warning::Failure during Tcl Build"
            exit 1
          }
          echo "TCL_CONFIG_PATH=`pwd`" >> $GITHUB_ENV
        working-directory: tcl/unix
      - name: Configure ${{ matrix.config }}
        run: |
          ./configure $CFGOPT --with-tcl=$TCL_CONFIG_PATH "--prefix=$HOME/install dir" || {
            cat config.log
            echo "::error::Failure during Configure"
            exit 1
          }
      - name: Build

  build:
    runs-on: ubuntu-22.04
    strategy:
      matrix:
        compiler:
          - "gcc"
          - "clang"
        config:
          - ""
          - "CFLAGS=-DTK_NO_DEPRECATED=1"
          - "--disable-shared"
          - "--disable-xft"
          - "--disable-xss"
          - "--enable-symbols"
    steps:

          touch tk/doc/man.macros tk/generic/tkStubInit.c
          echo "CFGOPT=$CFGOPT" >> $GITHUB_ENV
          echo "CC=$COMPILER" >> $GITHUB_ENV
          echo "TOOL_DIR=$(cd tcl/tools;pwd)" >> $GITHUB_ENV
          echo "BUILD_CONFIG_ID=$OPTS" >> $GITHUB_ENV
        working-directory: "."
        env:
          CFGOPT: ${{ matrix.config }}
          COMPILER: ${{ matrix.compiler }}
          OPTS: ${{ matrix.compiler }}${{ matrix.config }}
      - name: Configure and Build Tcl
        run: |
          ./configure $CFGOPT "--prefix=$HOME/install dir" || {
            cat config.log
            echo "::warning::Failure during Tcl Configure"
            exit 1
          }
          make all install  || {
            echo "::warning::Failure during Tcl Build"
            exit 1
          }
          echo "TCL_CONFIG_PATH=`pwd`" >> $GITHUB_ENV
        working-directory: tcl/unix
      - name: Configure (opts=${{ matrix.config }})
        run: |
          ./configure $CFGOPT --with-tcl=$TCL_CONFIG_PATH "--prefix=$HOME/install dir" || {
            cat config.log
            echo "::error::Failure during Configure"
            exit 1
          }
      - name: Build

          }
  test:
    runs-on: ubuntu-22.04
    strategy:
      matrix:
        compiler:
          - "gcc"
        config:
          - ""
          - "--disable-xft"
          - "--enable-symbols"
    steps:
      - name: Checkout
        uses: actions/checkout@v4
        with:
          path: tk
      - name: Checkout Tcl
        uses: actions/checkout@v4
        with:
          repository: tcltk/tcl
          ref: tip-626
          path: tcl
      - name: Setup Environment (compiler=${{ matrix.compiler }})
        run: |
          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.config }}
          COMPILER: ${{ matrix.compiler }}
      - name: Configure and Build Tcl
        run: |
          ./configure $CFGOPT "--prefix=$HOME/install dir" || {
            cat config.log
            echo "::warning::Failure during Tcl Configure"
            exit 1
          }
          make all install  || {
            echo "::warning::Failure during Tcl Build"
            exit 1
          }
          echo "TCL_CONFIG_PATH=`pwd`" >> $GITHUB_ENV
        working-directory: tcl/unix
      - name: Configure ${{ matrix.config }}
        run: |
          ./configure $CFGOPT --with-tcl=$TCL_CONFIG_PATH "--prefix=$HOME/install dir" || {
            cat config.log
            echo "::error::Failure during Configure"
            exit 1
          }
      - name: Build

Tk patch releases have the primary purpose of delivering bug fixes
to the userbase.

# Bug fixes
 - [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`.

Tk 9.0.1 continues the Tk 9.0 series of releases.  The Tk 9.0 series
does not support Tcl 8.6.  The Tk 9.0 series extends the Tcl 9.0 series.
To make use of Tk 9.0.1, first a Tcl 9.0 release must be present.
As new Tk features are developed, expect them to appear in Tk 9, but not

#include "tkMacOSXWm.h"


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

static Tcl_ObjCmdProc TestpressbuttonObjCmd;
static Tcl_ObjCmdProc TestmovemouseObjCmd;
static Tcl_ObjCmdProc TestinjectkeyeventObjCmd;
static Tcl_ObjCmdProc TestmenubarheightObjCmd;

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

TkplatformtestInit(
    Tcl_Interp *interp)		/* Interpreter to add commands to. */
{
    /*
     * Add commands for platform specific tests on MacOS here.
     */

    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;
}

/*
 *----------------------------------------------------------------------
 *
 * 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) {

    (void) drawable;
    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[] = {
	"flagschanged", "press", "release", NULL};

    if (winPtr->window == None) {
	Tk_MakeWindowExist((Tk_Window)winPtr);
    }
    if (!TkMacOSXHostToplevelExists(winPtr)) {
	TkMacOSXMakeRealWindowExist(winPtr);
    }
    if (WmSetAttribute(winPtr, TkMacOSXGetNSWindowForDrawable(winPtr->window), interp,
	    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) {
	    return TCL_ERROR;
	}
	wmPtr->hints.icon_pixmap = pixmap;
	wmPtr->hints.flags |= IconPixmapHint;

    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)]



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 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
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"}]
testConstraint utfcompat [expr {([string length "\U10000"] == 2) && [package vsatisfies [package provide Tcl] 8]}]


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\" 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 {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}

    # (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\" does not 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, -fixed, or -linespace}
test font-10.6 {font command: metrics: bad font} -body {
    # (tkfont == NULL)
    font metrics "\{xyz"
} -returnCodes error -result "font \"{xyz\" does not 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\" does not 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\" does not exist"
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 {
    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 {
    # if this test failed, start the investigations by reading ticket [8162e9b7a9]
    tk scaling 0.5
    font actual {times -13} -size
} -cleanup {
    tk scaling $oldscale
} -result 26
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-44.3 {font create with display scaling not 100% - bug 8162e9b7a9} -body {
    set font1 TkDefaultFont
    set font2 [font create Font2 {*}[font actual $font1]]
    expr {[font actual $font1 -size] == [font actual $font2 -size]}
} -cleanup {
    font delete $font2
} -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}
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
    }

} -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 {
    toplevel .t -width 200 -height 100 -screen $env(DISPLAY)
    wm geometry .t +0+0
    .t configure -screen
} -cleanup {
    deleteWindows
} -result $expectedScreen
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

# This file is a Tcl script to test menus in Tk.  It is
# organized in the standard fashion for Tcl tests.
#
# 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
imageInit




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
}

test menu-41.1 {identifiers - auto generated} -setup {
    destroy .m
} -body {
    menu .m
    list [.m add command -label 1] [.m add command -label 2] [.m add command -label 3]

    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 {Tk_UseWindow 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 © 1998-1999 Scriptics Corporation.
# All rights reserved.

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




if {[tk windowingsystem] eq "x11"} {
    if {[testConstraint 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 {[testConstraint 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
	    }
	}


    }
}

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

# Fonts must be fixed width and have chars missing below char 32, so that
# tests can control char expansion and missing character code. Therefore
# we're using TkFixedFont here for both the label and the canvas.



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 TkFixedFont]
pack .b.c
update

set cx [font measure TkFixedFont 0]

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 "" does not 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 TkFixedFont "䀀"]   ;# 6
    incr x [font measure TkFixedFont "\002"]   ;# 4
    incr x [font measure TkFixedFont "\012"]   ;# 2
    incr x [font measure TkFixedFont "\101"]   ;# 1
    set x
} [expr $cx*13]
test unixfont-8.5 {InitFont procedure: setup widths of normal chars} x11 {
    font metrics TkFixedFont -fixed
} 1
test unixfont-8.6 {InitFont procedure: setup widths of special chars} {x11 nonPortable} {
# Constrained by nonPortable, see unixfont-8.4
    set x 0
    incr x [font measure TkFixedFont "\001"]   ;# 4
    incr x [font measure TkFixedFont "\002"]   ;# 4
    incr x [font measure TkFixedFont "\012"]   ;# 2
    set x
} [expr $cx*10]
test unixfont-8.7 {InitFont procedure: XA_UNDERLINE_POSITION} x11 {
    catch {font actual -adobe-courier-bold-i-normal--0-0-0-0-m-0-iso8859-1}
    set x {}
} {}
test unixfont-8.8 {InitFont procedure: no 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 nonPortable} {
# Constrained by nonPortable, see unixfont-8.4
    .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 nonPortable} {
# Constrained by nonPortable, see unixfont-8.4
    .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]

# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

package require tcltest 2.2
namespace import ::tcltest::*
tcltest::configure {*}$argv
tcltest::loadTestedCommands



global longValue selValue selInfo

set selValue {}
set selInfo {}

proc handler {type offset count} {
    global selValue selInfo

    dobg {string length [selection get]}
} -cleanup {
    cleanupbg
    destroy .e
} -result 4

test unixSelect-1.2 {TkSelGetSelection procedure: simple i18n text, iso8859-1} -constraints {
    x11
} -setup {
    setupbg
} -body {
    dobg {
	pack [entry .e]
	update
	.e insert 0 üф

    }
    selection get -type UTF8_STRING
} -cleanup {
    cleanupbg
} -result [string repeat x 3999]ü[string repeat x 4000]

test unixSelect-1.13 {TkSelGetSelection procedure: simple i18n text, utf-8} -constraints {
    x11
} -setup {
    destroy .e
    setupbg
} -body {
    pack [entry .e]
    update
    .e insert 0 überф
    .e selection range 0 end
    dobg {string length [selection get -type UTF8_STRING]}
} -cleanup {
    destroy .e
    cleanupbg
} -result 5

test unixSelect-1.14 {TkSelGetSelection procedure: simple i18n text, utf-8} -constraints {
    x11
} -setup {
    setupbg
} -body {
    dobg {
	pack [entry .e]
	update
	.e insert 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

	    WM_HINTS] 0]]]
    lappend result [wm iconbitmap .t] $bit
    wm iconbitmap .t {}
    set bit [format 0x%x [expr 0x4 & [lindex [testprop [testwrapper .t] \
	    WM_HINTS] 0]]]
    lappend result [wm iconbitmap .t] $bit
} {{} questhead 0x4 {} 0x0}





test unixWm-22.3 {Tk_WmCmd procedure, "iconbitmap" option} unix {

    list [catch {wm iconbitmap .t bad-bitmap} msg] $msg

} {1 {bitmap "bad-bitmap" not defined}}

test unixWm-23.1 {Tk_WmCmd procedure, "iconify" option} unix {
    list [catch {wm iconify .t 12} msg] $msg
} {1 {wrong # args: should be "wm iconify window"}}
test unixWm-23.2 {Tk_WmCmd procedure, "iconify" option} unix {
    destroy .t2
    toplevel .t2

} -result {wrong # args: should be "wm iconbitmap window ?bitmap?"}
test wm-iconbitmap-1.2.2 {usage} -constraints win -returnCodes error -body {
    wm iconbitmap .t 12 13 14
} -result {wrong # args: should be "wm iconbitmap window ?-default? ?image?"}
test wm-iconbitmap-1.3 {usage} -constraints win -returnCodes error -body {
    wm iconbitmap .t 12 13
} -result {illegal option "12" must be "-default"}
test wm-iconbitmap-1.4 {usage} -returnCodes error -body {
    wm iconbitmap .t bad-bitmap
} -result {bitmap "bad-bitmap" not defined}

test wm-iconbitmap-2.1 {setting and reading values} -setup {
    set result {}
} -body {
    lappend result [wm iconbitmap .t]
    wm iconbitmap .t hourglass
    lappend result [wm iconbitmap .t]
    wm iconbitmap .t {}
    lappend result [wm iconbitmap .t]

 *	which actually is issue #216 in XQuartz:
 *	https://github.com/XQuartz/XQuartz/issues/216
 *
 *-------------------------------------------------------------------------
 */

static XFontStruct *
XLoadQueryFontNoXError(Display *display, const char *name)
{
    XFontStruct *fontStructPtr = NULL;
    Tk_ErrorHandler handler;

    /* 45 is the major opcode of X_OpenFont */
    handler = Tk_CreateErrorHandler(display, BadValue, 45, -1, NULL, NULL);
    fontStructPtr = XLoadQueryFont(display, name);