path: root/tcl/tests/raise.test

# This file is a Tcl script to test out Tk's "raise" and
# "lower" commands, plus associated code to manage window
# stacking order.  It is organized in the standard fashion
# for Tcl tests.
#
# Copyright (c) 1993-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$

package require tcltest 2.1
namespace import -force tcltest::configure
namespace import -force tcltest::testsDirectory
configure -testdir [file join [pwd] [file dirname [info script]]]
configure -loadfile [file join [testsDirectory] constraints.tcl]
tcltest::loadTestedCommands

testConstraint testmakeexist [llength [info commands testmakeexist]]

# Procedure to create a bunch of overlapping windows, which should
# make it easy to detect differences in order.

proc raise_setup {} {
    foreach i [winfo child .raise] {
	destroy $i
    }
    foreach i {a b c d e} {
	label .raise.$i -text $i -relief raised -bd 2
    }
    place .raise.a -x 20 -y 60 -width 60 -height 80
    place .raise.b -x 60 -y 60 -width 60 -height 80
    place .raise.c -x 100 -y 60 -width 60 -height 80
    place .raise.d -x 40 -y 20 -width 100 -height 60
    place .raise.e -x 40 -y 120 -width 100 -height 60
}

# Procedure to return information about which windows are on top
# of which other windows.

proc raise_getOrder {} {
    set x [winfo rootx .raise]
    set y [winfo rooty .raise]
    list [winfo name [winfo containing [expr $x+50] [expr $y+70]]] \
	    [winfo name [winfo containing [expr $x+90] [expr $y+70]]] \
	    [winfo name [winfo containing [expr $x+130] [expr $y+70]]] \
	    [winfo name [winfo containing [expr $x+70] [expr $y+100]]] \
	    [winfo name [winfo containing [expr $x+110] [expr $y+100]]] \
	    [winfo name [winfo containing [expr $x+50] [expr $y+130]]] \
	    [winfo name [winfo containing [expr $x+90] [expr $y+130]]] \
	    [winfo name [winfo containing [expr $x+130] [expr $y+130]]]
}

# Procedure to set up a collection of top-level windows

proc raise_makeToplevels {} {
    deleteWindows
    foreach i {.raise1 .raise2 .raise3} {
	toplevel $i
	wm geom $i 150x100+0+0
	update
    }
}

toplevel .raise
wm geom .raise 250x200+0+0

test raise-1.1 {preserve creation order} {
    raise_setup
    tkwait visibility .raise.e
    raise_getOrder
} {d d d b c e e e}
test raise-1.2 {preserve creation order} testmakeexist {
    raise_setup
    testmakeexist .raise.a
    update
    raise_getOrder
} {d d d b c e e e}
test raise-1.3 {preserve creation order} testmakeexist {
    raise_setup
    testmakeexist .raise.c
    update
    raise_getOrder
} {d d d b c e e e}
test raise-1.4 {preserve creation order} testmakeexist {
    raise_setup
    testmakeexist .raise.e
    update
    raise_getOrder
} {d d d b c e e e}
test raise-1.5 {preserve creation order} testmakeexist {
    raise_setup
    testmakeexist .raise.d .raise.c .raise.b
    update
    raise_getOrder
} {d d d b c e e e}

test raise-2.1 {raise internal windows before creation} {
    raise_setup
    raise .raise.a
    update
    raise_getOrder
} {a d d a c a e e}
test raise-2.2 {raise internal windows before creation} {
    raise_setup
    raise .raise.c
    update
    raise_getOrder
} {d d c b c e e c}
test raise-2.3 {raise internal windows before creation} {
    raise_setup
    raise .raise.e
    update
    raise_getOrder
} {d d d b c e e e}
test raise-2.4 {raise internal windows before creation} {
    raise_setup
    raise .raise.e .raise.a
    update
    raise_getOrder
} {d d d b c e b c}
test raise-2.5 {raise internal windows before creation} {
    raise_setup
    raise .raise.a .raise.d
    update
    raise_getOrder
} {a d d a c e e e}

test raise-3.1 {raise internal windows after creation} {
    raise_setup
    update
    raise .raise.a .raise.d
    raise_getOrder
} {a d d a c e e e}
test raise-3.2 {raise internal windows after creation} testmakeexist {
    raise_setup
    testmakeexist .raise.a .raise.b
    raise .raise.a .raise.b
    update
    raise_getOrder
} {d d d a c e e e}
test raise-3.3 {raise internal windows after creation} testmakeexist {
    raise_setup
    testmakeexist .raise.a .raise.d
    raise .raise.a .raise.b
    update
    raise_getOrder
} {d d d a c e e e}
test raise-3.4 {raise internal windows after creation} testmakeexist {
    raise_setup
    testmakeexist .raise.a .raise.c .raise.d
    raise .raise.a .raise.b
    update
    raise_getOrder
} {d d d a c e e e}

test raise-4.1 {raise relative to nephews} {
    raise_setup
    update
    frame .raise.d.child
    raise .raise.a .raise.d.child
    raise_getOrder
} {a d d a c e e e}
test raise-4.2 {raise relative to nephews} {
    raise_setup
    update
    frame .raise2
    list [catch {raise .raise.a .raise2} msg] $msg
} {1 {can't raise ".raise.a" above ".raise2"}}
catch {destroy .raise2}

test raise-5.1 {lower internal windows} {
    raise_setup
    update
    lower .raise.d
    raise_getOrder
} {a b c b c e e e}
test raise-5.2 {lower internal windows} {
    raise_setup
    update
    lower .raise.d .raise.b
    raise_getOrder
} {d b c b c e e e}
test raise-5.3 {lower internal windows} {
    raise_setup
    update
    lower .raise.a .raise.e
    raise_getOrder
} {a d d a c e e e}
test raise-5.4 {lower internal windows} {
    raise_setup
    update
    frame .raise2
    list [catch {lower .raise.a .raise2} msg] $msg
} {1 {can't lower ".raise.a" below ".raise2"}}
catch {destroy .raise2}

test raise-6.1 {raise/lower toplevel windows} {nonPortable} {
    raise_makeToplevels
    update
    raise .raise1
    winfo containing [winfo rootx .raise1] [winfo rooty .raise1]
} .raise1
test raise-6.2 {raise/lower toplevel windows} {nonPortable} {
    raise_makeToplevels
    update
    raise .raise2
    winfo containing [winfo rootx .raise1] [winfo rooty .raise1]
} .raise2
test raise-6.3 {raise/lower toplevel windows} {nonPortable} {
    raise_makeToplevels
    update
    raise .raise3
    raise .raise2
    raise .raise1 .raise3
    set result [winfo containing [winfo rootx .raise1] \
	    [winfo rooty .raise1]]
    destroy .raise2
    update
    after 500
    list $result [winfo containing [winfo rootx .raise1] \
	    [winfo rooty .raise1]]
} {.raise2 .raise1}
test raise-6.4 {raise/lower toplevel windows} {nonPortable} {
    raise_makeToplevels
    update
    raise .raise2
    raise .raise1
    lower .raise3 .raise1
    set result [winfo containing [winfo rootx .raise1] \
	    [winfo rooty .raise1]]
    wm geometry .raise2 +30+30
    wm geometry .raise1 +60+60
    destroy .raise1
    update
    after 500
    list $result [winfo containing [winfo rootx .raise2] \
	    [winfo rooty .raise2]]
} {.raise1 .raise3}
test raise-6.5 {raise/lower toplevel windows} {nonPortable} {
    raise_makeToplevels
    raise .raise1
    set time [lindex [time {raise .raise1}] 0]
    expr {$time < 2000000}
} 1
test raise-6.6 {raise/lower toplevel windows} {nonPortable} {
    raise_makeToplevels
    update
    raise .raise2
    raise .raise1
    raise .raise3
    frame .raise1.f1
    frame .raise1.f1.f2
    lower .raise3 .raise1.f1.f2
    set result [winfo containing [winfo rootx .raise1] \
	    [winfo rooty .raise1]]
    destroy .raise1
    update
    after 500
    list $result [winfo containing [winfo rootx .raise2] \
	    [winfo rooty .raise2]]
} {.raise1 .raise3}

test raise-7.1 {errors in raise/lower commands} {
    list [catch {raise} msg] $msg
} {1 {wrong # args: should be "raise window ?aboveThis?"}}
test raise-7.2 {errors in raise/lower commands} {
    list [catch {raise a b c} msg] $msg
} {1 {wrong # args: should be "raise window ?aboveThis?"}}
test raise-7.3 {errors in raise/lower commands} {
    list [catch {raise badName} msg] $msg
} {1 {bad window path name "badName"}}
test raise-7.4 {errors in raise/lower commands} {
    list [catch {raise . badName2} msg] $msg
} {1 {bad window path name "badName2"}}
test raise-7.5 {errors in raise/lower commands} {
    list [catch {lower} msg] $msg
} {1 {wrong # args: should be "lower window ?belowThis?"}}
test raise-7.6 {errors in raise/lower commands} {
    list [catch {lower a b c} msg] $msg
} {1 {wrong # args: should be "lower window ?belowThis?"}}
test raise-7.7 {errors in raise/lower commands} {
    list [catch {lower badName3} msg] $msg
} {1 {bad window path name "badName3"}}
test raise-7.8 {errors in raise/lower commands} {
    list [catch {lower . badName4} msg] $msg
} {1 {bad window path name "badName4"}}

deleteWindows

# cleanup
::tcltest::cleanupTests
return