Tk Source Code

2003-11-17  Don Porter	<[email protected]>

	* tests/constraints.tcl:When running the test suite in a process
	* tests/image.test:	where Tk has been [load]ed, there's no
	* tests/select.test:	guarantee that child processes created by
	* tests/unixWm.test:	[exec [interpreter]] will have Tk in them.
	* tests/window.test:	Made modifications to force a [load] of Tk
				in those situations.

2003-11-17  Jeff Hobbs  <[email protected]>

	* generic/tkMenubutton.h: fixed compound menubutton handling like
	* generic/tkMenubutton.c: *button corrections of 2003-04-25.
	* mac/tkMacMenubutton.c (TkpDisplayMenuButton): 
	* unix/tkUnixMenubu.c (TkpDisplayMenuButton): 

    update
}

package require tcltest 2.1

namespace eval tk {
    namespace eval test {

	namespace export loadTkCommand
	proc loadTkCommand {} {
	    set tklib {}
	    foreach pair [info loaded {}] {
		foreach {lib pfx} $pair break
		if {$pfx eq "Tk"} {
		    set tklib $lib
		    break
		}
	    }
	    return [list load $tklib Tk]
	}

	namespace eval bg {
	    # Manage a background process.  
	    # Replace with slave interp or thread?
	    namespace import ::tcltest::interpreter
	    namespace import ::tk::test::loadTkCommand
	    namespace export setup cleanup do

	    proc cleanup {} {
		variable fd
		# catch in case the background process has closed $fd
		catch {puts $fd exit}
		catch {close $fd}

		if {[gets $fd data] < 0} {
		    error "unexpected EOF from \"[interpreter]\""
		}
		if {$data ne "foo"} {
		    error "unexpected output from\
			    background process: \"$data\""
		}
		puts $fd [loadTkCommand]
		flush $fd
		fileevent $fd readable [namespace code Ready]
	    }
	    proc Ready {} {
		variable fd
		variable Data
		variable Done
		set x [gets $fd]

# This file is a Tcl script to test out the "image" command and the
# other procedures in the file tkImage.c.  It is organized in the
# standard fashion for Tcl tests.
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
# RCS: @(#) $Id: image.test,v 1.12 2003/11/18 01:47:51 dgp Exp $

package require tcltest 2.1
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force ::tk::test::loadTkCommand

eval image delete [image names]
canvas .c -highlightthickness 2
pack .c
update
test image-1.1 {Tk_ImageCmd procedure, "create" option} {
    list [catch image msg] $msg

} {{myimage get} {myimage get} {myimage display 0 0 30 15 30 30} {myimage display 0 0 30 15 30 130}}
test image-1.9 {Tk_ImageCmd procedure, "create" option} testImageType {
    .c delete all
    eval image delete [image names]
    list [catch {image create test -badName foo} msg] $msg [image names]
} {1 {bad option name "-badName"} {}}
test image-1.10 {Tk_ImageCmd procedure, "create" option with same name as main window} {
    set code [loadTkCommand]
    append code {
	update
	puts [list [catch {image create photo .} msg] $msg]
	exit
    }
    set script [makeFile $code script]
    set x [list [catch {exec [interpreter] <$script} msg] $msg]
    removeFile script
    set x
} {0 {1 {images may not be named the same as the main window}}}
test image-1.11 {Tk_ImageCmd procedure, "create" option with same name as main window after renaming} {
    set code [loadTkCommand]
    append code {
	update
	puts [list [catch {rename . foo;image create photo foo} msg] $msg]
	exit
    }
    set script [makeFile $code script]
    set x [list [catch {exec [interpreter] <$script} msg] $msg]
    removeFile script
    set x
} {0 {1 {images may not be named the same as the main window}}}
test image-1.11 {Tk_ImageCmd, "create" option: do not generated command name in use} -setup {
    set i [image create bitmap]
    regexp {^image(\d+)$} $i -> serial

# This file is a Tcl script to test out Tk's selection management code,
# especially the "selection" command.  It is organized in the standard
# fashion for Tcl tests.
#
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
# RCS: @(#) $Id: select.test,v 1.11 2003/11/18 01:47:51 dgp Exp $

#
# Note: Multiple display selection handling will only be tested if the
# environment variable TK_ALT_DISPLAY is set to an alternate display.
#

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

namespace import -force ::tk::test:loadTkCommand

global longValue selValue selInfo

set selValue {}
set selInfo {}

proc handler {type offset count} {

test select-10.1 {ConvertSelection procedure, race with selection clear} {unixOnly} {
    setup
    proc Ready {fd} {
	variable x
	lappend x [gets $fd]
    }
    set fd [open "|[list [interpreter] -geometry +0+0 -name tktest]" r+]
    puts $fd "puts foo; [loadTkCommand]; flush stdout"
    flush $fd
    gets $fd
    fileevent $fd readable [list Ready $fd]
    set selValue "Just a simple test"
    set selInfo ""
    selection handle .f1 {handler STRING}
    update
    puts $fd {puts "[catch {selection get} msg] $msg"; puts **DONE**; flush stdout}
    flush $fd
    after 200
    selection own .
    set x {}
    vwait [namespace which -variable x]
    puts $fd {exit}
    flush $fd
    # Don't understand why, but the [loadTkCommand] above causes
    # a "broken pipe" error when Tk was actually [load]ed in the child.
    catch {close $fd}
    lappend x $selInfo
} {{1 PRIMARY selection doesn't exist or form "STRING" not defined} {}}
test select-10.2 {ConvertSelection procedure} {unixOnly} {
    setup
    setupbg
    set selValue [string range $longValue 0 3999]
    set selInfo ""

# This file is a Tcl script to test out Tk's interactions with
# the window manager, including the "wm" command.  It is organized
# in the standard fashion for Tcl tests.
#
# Copyright (c) 1992-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
# RCS: @(#) $Id: unixWm.test,v 1.36 2003/11/18 01:47:51 dgp Exp $

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

namespace import -force ::tk::test:loadTkCommand

proc sleep ms {
    global x
    after $ms {set x 1}
    vwait x
}

    } else {
	set error 0
    }
    removeFile script
    list $error $msg
} {0 {}}
test unixWm-59.2 {exit processing} unix {
    set code [loadTkCommand]
    append code  {
	interp create x
	x eval {set argc 2}
	x eval {set argv "-geometry 10x10+0+0"}
	x eval {load {} Tk}
	update
	exit
    }
    set script [makeFile $code script]
    if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} {
	set error 1
    } else {
	set error 0
    }
    removeFile script
    list $error $msg
} {0 {}}
test unixWm-59.3 {exit processing} unix {
    set code [loadTkCommand]
    append code  {
	interp create x
	x eval {set argc 2}
	x eval {set argv "-geometry 10x10+0+0"}
	x eval {load {} Tk}
	x eval {
	    button .b -text hello
	    bind .b <Destroy> foo
	}
	x alias foo destroy_x
	proc destroy_x {} {interp delete x}
	update
	exit
    }
    set script [makeFile $code script]
    if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} {
	set error 1
    } else {
	set error 0
    }
    removeFile script
    list $error $msg

# This file is a Tcl script to test the procedures in the file
# tkWindow.c.  It is organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1995 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
# RCS: @(#) $Id: window.test,v 1.9 2003/11/18 01:47:51 dgp Exp $

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

namespace import -force ::tk::test::loadTkCommand
update

# XXX This file is woefully incomplete.  Right now it only tests
# a few parts of a few procedures in tkWindow.c

test window-1.1 {Tk_CreateWindowFromPath procedure, parent dead} {
    proc bgerror msg {

    place .f.t.f.f -relx 1 -rely 1 -anchor se
    update
    destroy .f
} {}

test window-2.4 {Tk_DestroyWindow, cleanup half dead window at exit} \
        unixOrWin {
    set code [loadTkCommand]
    append code {
        update
        bind . <Destroy> exit
        destroy .
    }
    set script [makeFile $code script]
    if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} {
	set error 1
    } else {
	set error 0
    }
    removeFile script
    list $error $msg
} {0 {}}

test window-2.5 {Tk_DestroyWindow, cleanup half dead windows at exit} \
        unixOrWin {
    set code [loadTkCommand]
    append code {
        toplevel .t
        update
        bind .t <Destroy> exit
        destroy .t
    }
    set script [makeFile $code script]
    if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} {
	set error 1
    } else {
	set error 0
    }
    removeFile script
    list $error $msg
} {0 {}}

test window-2.6 {Tk_DestroyWindow, cleanup half dead windows at exit} \
        unixOrWin {
    set code [loadTkCommand]
    append code {
        toplevel .t
        update
        bind .t <Destroy> exit
        destroy .
    }
    set script [makeFile $code script]
    if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} {
	set error 1
    } else {
	set error 0
    }
    removeFile script
    list $error $msg
} {0 {}}

test window-2.7 {Tk_DestroyWindow, cleanup half dead windows at exit} \
        unixOrWin {
    set code [loadTkCommand]
    append code {
        toplevel .t
        toplevel .t.f
        update
        bind .t.f <Destroy> exit
        destroy .
    }
    set script [makeFile $code script]
    if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} {
	set error 1
    } else {
	set error 0
    }
    removeFile script
    list $error $msg
} {0 {}}

test window-2.8 {Tk_DestroyWindow, cleanup half dead windows at exit} \
        unixOrWin {
    set code [loadTkCommand]
    append code {
        toplevel .t1
        toplevel .t2
        toplevel .t3
        update
        bind .t3 <Destroy> {destroy .t2}
        bind .t2 <Destroy> {destroy .t1}
        bind .t1 <Destroy> {exit 0}
        destroy .t3
    }
    set script [makeFile $code script]
    if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} {
	set error 1
    } else {
	set error 0
    }
    removeFile script
    list $error $msg
} {0 {}}

test window-2.9 {Tk_DestroyWindow, Destroy bindings
        evaluated after exit} unixOrWin {
    set code [loadTkCommand]
    append code {
        toplevel .t1
        toplevel .t2
        update
        bind .t2 <Destroy> {puts "Destroy .t2" ; exit 1}
        bind .t1 <Destroy> {puts "Destroy .t1" ; exit 0}
        destroy .t2
    }
    set script [makeFile $code script]
    if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} {
	set error 1
    } else {
	set error 0
    }
    removeFile script
    list $error $msg
} {0 {Destroy .t2
Destroy .t1}}

test window-2.10 {Tk_DestroyWindow, Destroy binding
        evaluated once} unixOrWin {
    set code [loadTkCommand]
    append code {
        update
        bind . <Destroy> {
            puts "Destroy ."
            bind . <Destroy> {puts "Re-Destroy ."}
            exit 0
        }
        destroy .
    }
    set script [makeFile $code script]
    if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} {
	set error 1
    } else {
	set error 0
    }
    removeFile script
    list $error $msg
} {0 {Destroy .}}

test window-2.11 {Tk_DestroyWindow, don't reanimate a half-dead window} \
        unixOrWin {
    set code [loadTkCommand]
    append code {
        toplevel .t1
        toplevel .t2
        update
        bind .t1 <Destroy> {
            if {[catch {entry .t2.newchild}]} {
                puts YES
            } else {
                puts NO
            }
        }
        bind .t2 <Destroy> {exit}
        destroy .t2
    }
    set script [makeFile $code script]
    if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} {
	set error 1
    } else {
	set error 0
    }
    removeFile script
    list $error $msg