archie/tk4.2/tests/scrollbar.test
2024-05-27 16:40:40 +02:00

436 lines
15 KiB
Plaintext

# This file is a Tcl script to test out scrollbar widgets and
# the "scrollbar" command of Tk. 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.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# SCCS: @(#) scrollbar.test 1.16 96/02/16 10:55:21
if {[info procs test] != "test"} {
source defs
}
foreach i [winfo children .] {
destroy $i
}
wm geometry . {}
raise .
proc scroll args {
global scrollInfo
set scrollInfo $args
}
# XXX Note: this test file is woefully incomplete. Right now there are
# only bits and pieces of tests. Please make this file more complete
# as you fix bugs and add features.
frame .f -height 200 -width 1
pack .f -side left
scrollbar .s
pack .s -side right -fill y
update
set i 1
foreach test {
{-activebackground #ff0000 #ff0000 non-existent
{unknown color name "non-existent"}}
{-activerelief sunken sunken non-existent
{bad relief type "non-existent": must be flat, groove, raised, ridge, or sunken}}
{-background #ff0000 #ff0000 non-existent
{unknown color name "non-existent"}}
{-bd 4 4 badValue {bad screen distance "badValue"}}
{-bg #ff0000 #ff0000 non-existent
{unknown color name "non-existent"}}
{-borderwidth 1.3 1 badValue {bad screen distance "badValue"}}
{-command "set x" {set x} {} {}}
{-elementborderwidth 4 4 badValue {bad screen distance "badValue"}}
{-cursor arrow arrow badValue {bad cursor spec "badValue"}}
{-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}}
{-highlightcolor #123456 #123456 bogus {unknown color name "bogus"}}
{-highlightthickness 6 6 bogus {bad screen distance "bogus"}}
{-highlightthickness -2 0 {} {}}
{-jump true 1 silly {expected boolean value but got "silly"}}
{-orient horizontal horizontal badValue
{bad orientation "badValue": must be vertical or horizontal}}
{-orient horizontal horizontal bogus {bad orientation "bogus": must be vertical or horizontal}}
{-relief ridge ridge badValue {bad relief type "badValue": must be flat, groove, raised, ridge, or sunken}}
{-repeatdelay 140 140 129.3 {expected integer but got "129.3"}}
{-repeatinterval 140 140 129.3 {expected integer but got "129.3"}}
{-takefocus "any string" "any string" {} {}}
{-trough #432 #432 lousy {unknown color name "lousy"}}
{-width 32 32 badValue {bad screen distance "badValue"}}
} {
set name [lindex $test 0]
test scroll-1.$i {configuration options} {
.s configure $name [lindex $test 1]
lindex [.s configure $name] 4
} [lindex $test 2]
incr i
if {[lindex $test 3] != ""} {
test scroll-1.$i {configuration options} {
list [catch {.s configure $name [lindex $test 3]} msg] $msg
} [list 1 [lindex $test 4]]
}
.s configure $name [lindex [.s configure $name] 3]
incr i
}
destroy .s
test scroll-2.1 {Tk_ScrollbarCmd procedure} {
list [catch {scrollbar} msg] $msg
} {1 {wrong # args: should be "scrollbar pathName ?options?"}}
test scroll-2.2 {Tk_ScrollbarCmd procedure} {
list [catch {scrollbar gorp} msg] $msg
} {1 {bad window path name "gorp"}}
test scroll-2.3 {Tk_ScrollbarCmd procedure} {
scrollbar .s
set x "[winfo class .s] [info command .s]"
destroy .s
set x
} {Scrollbar .s}
test scroll-2.4 {Tk_ScrollbarCmd procedure} {
list [catch {scrollbar .s -gorp blah} msg] $msg [winfo exists .s] \
[info command .s]
} {1 {unknown option "-gorp"} 0 {}}
test scroll-2.5 {Tk_ScrollbarCmd procedure} {
set x [scrollbar .s]
destroy .s
set x
} {.s}
scrollbar .s -orient vertical -command scroll
pack .s -side right -fill y
update
test scroll-3.1 {ScrollbarWidgetCmd procedure} {
list [catch {.s} msg] $msg
} {1 {wrong # args: should be ".s option ?arg arg ...?"}}
test scroll-3.2 {ScrollbarWidgetCmd procedure, "cget" option} {
list [catch {.s cget} msg] $msg
} {1 {wrong # args: should be ".s cget option"}}
test scroll-3.3 {ScrollbarWidgetCmd procedure, "cget" option} {
list [catch {.s cget -gorp} msg] $msg
} {1 {unknown option "-gorp"}}
test scroll-3.4 {ScrollbarWidgetCmd procedure, "activate" option} {
list [catch {.s activate a b} msg] $msg
} {1 {wrong # args: should be ".s activate element"}}
test scroll-3.5 {ScrollbarWidgetCmd procedure, "activate" option} {
.s activate arrow1
.s activate
} {arrow1}
test scroll-3.6 {ScrollbarWidgetCmd procedure, "activate" option} {
.s activate slider
.s activate
} {slider}
test scroll-3.7 {ScrollbarWidgetCmd procedure, "activate" option} {
.s activate arrow2
.s activate
} {arrow2}
test scroll-3.8 {ScrollbarWidgetCmd procedure, "activate" option} {
.s activate s
.s activate {}
.s activate
} {}
test scroll-3.9 {ScrollbarWidgetCmd procedure, "activate" option} {
list [catch {.s activate trough1} msg] $msg
} {0 {}}
test scroll-3.10 {ScrollbarWidgetCmd procedure, "cget" option} {
list [catch {.s cget -orient} msg] $msg
} {0 vertical}
test scroll-3.11 {ScrollbarWidgetCmd procedure, "configure" option} {
llength [.s configure]
} {20}
test scroll-3.12 {ScrollbarWidgetCmd procedure, "configure" option} {
list [catch {.s configure -bad} msg] $msg
} {1 {unknown option "-bad"}}
test scroll-3.13 {ScrollbarWidgetCmd procedure, "configure" option} {
.s configure -orient
} {-orient orient Orient vertical vertical}
test scroll-3.14 {ScrollbarWidgetCmd procedure, "configure" option} {
.s configure -orient horizontal
set x [.s cget -orient]
.s configure -orient vertical
set x
} {horizontal}
test scroll-3.15 {ScrollbarWidgetCmd procedure, "configure" option} {
list [catch {.s configure -bad worse} msg] $msg
} {1 {unknown option "-bad"}}
test scroll-3.16 {ScrollbarWidgetCmd procedure, "delta" option} {
list [catch {.s delta 24} msg] $msg
} {1 {wrong # args: should be ".s delta xDelta yDelta"}}
test scroll-3.17 {ScrollbarWidgetCmd procedure, "delta" option} {
list [catch {.s delta 24 35 42} msg] $msg
} {1 {wrong # args: should be ".s delta xDelta yDelta"}}
test scroll-3.18 {ScrollbarWidgetCmd procedure, "delta" option} {
list [catch {.s delta silly 24} msg] $msg
} {1 {expected integer but got "silly"}}
test scroll-3.19 {ScrollbarWidgetCmd procedure, "delta" option} {
list [catch {.s delta 18 xxyz} msg] $msg
} {1 {expected integer but got "xxyz"}}
test scroll-3.20 {ScrollbarWidgetCmd procedure, "delta" option} {
list [catch {.s delta 18 xxyz} msg] $msg
} {1 {expected integer but got "xxyz"}}
test scroll-3.21 {ScrollbarWidgetCmd procedure, "delta" option} {
.s delta 20 0
} {0}
test scroll-3.22 {ScrollbarWidgetCmd procedure, "delta" option} {
.s delta 0 20
} {0.125786}
test scroll-3.23 {ScrollbarWidgetCmd procedure, "delta" option} {
.s delta 0 -20
} {-0.125786}
test scroll-3.24 {ScrollbarWidgetCmd procedure, "delta" option} {
toplevel .t -width 250 -height 100
wm geom .t +0+0
scrollbar .t.s -orient horizontal -borderwidth 2
place .t.s -width 201
update
set result [list [.t.s delta 0 20] [.t.s delta 160 0]]
destroy .t
set result
} {0 1}
test scroll-3.25 {ScrollbarWidgetCmd procedure, "fraction" option} {
list [catch {.s fraction 24} msg] $msg
} {1 {wrong # args: should be ".s fraction x y"}}
test scroll-3.26 {ScrollbarWidgetCmd procedure, "fraction" option} {
list [catch {.s fraction 24 30 32} msg] $msg
} {1 {wrong # args: should be ".s fraction x y"}}
test scroll-3.27 {ScrollbarWidgetCmd procedure, "fraction" option} {
list [catch {.s fraction silly 24} msg] $msg
} {1 {expected integer but got "silly"}}
test scroll-3.28 {ScrollbarWidgetCmd procedure, "fraction" option} {
list [catch {.s fraction 24 bogus} msg] $msg
} {1 {expected integer but got "bogus"}}
test scroll-3.29 {ScrollbarWidgetCmd procedure, "fraction" option} {
.s fraction 0 0
} {0}
test scroll-3.30 {ScrollbarWidgetCmd procedure, "fraction" option} {
.s fraction 0 1000
} {1}
test scroll-3.31 {ScrollbarWidgetCmd procedure, "fraction" option} {
.s fraction 4 21
} {0.00628931}
test scroll-3.32 {ScrollbarWidgetCmd procedure, "fraction" option} {
.s fraction 4 179
} {1}
test scroll-3.33 {ScrollbarWidgetCmd procedure, "fraction" option} {
.s fraction 4 178
} {0.993711}
toplevel .t -width 250 -height 100
wm geom .t +0+0
scrollbar .t.s -orient horizontal -borderwidth 2
place .t.s -width 201
update
test scroll-3.34 {ScrollbarWidgetCmd procedure, "fraction" option} {
.t.s fraction 100 0
} {0.5}
place configure .t.s -width [expr [winfo reqwidth .t.s] - 4]
update
test scroll-3.35 {ScrollbarWidgetCmd procedure, "fraction" option} {
.t.s fraction 100 0
} {0}
destroy .t
test scroll-3.36 {ScrollbarWidgetCmd procedure, "get" option} {
list [catch {.s get a} msg] $msg
} {1 {wrong # args: should be ".s get"}}
test scroll-3.37 {ScrollbarWidgetCmd procedure, "get" option} {
.s set 100 10 13 14
.s get
} {100 10 13 14}
test scroll-3.38 {ScrollbarWidgetCmd procedure, "get" option} {
.s set 0.6 0.8
.s get
} {0.6 0.8}
test scroll-3.39 {ScrollbarWidgetCmd procedure, "identify" option} {
list [catch {.s identify 0} msg] $msg
} {1 {wrong # args: should be ".s identify x y"}}
test scroll-3.40 {ScrollbarWidgetCmd procedure, "identify" option} {
list [catch {.s identify 0 0 1} msg] $msg
} {1 {wrong # args: should be ".s identify x y"}}
test scroll-3.41 {ScrollbarWidgetCmd procedure, "identify" option} {
list [catch {.s identify bogus 2} msg] $msg
} {1 {expected integer but got "bogus"}}
test scroll-3.42 {ScrollbarWidgetCmd procedure, "identify" option} {
list [catch {.s identify -1 bogus} msg] $msg
} {1 {expected integer but got "bogus"}}
test scroll-3.43 {ScrollbarWidgetCmd procedure, "identify" option} {
.s identify 5 5
} {arrow1}
test scroll-3.44 {ScrollbarWidgetCmd procedure, "identify" option} {
.s identify 5 35
} {trough1}
test scroll-3.45 {ScrollbarWidgetCmd procedure, "identify" option} {
.s set .3 .6
.s identify 5 100
} {slider}
test scroll-3.46 {ScrollbarWidgetCmd procedure, "identify" option} {
.s identify 5 145
} {trough2}
test scroll-3.47 {ScrollbarWidgetCmd procedure, "identify" option} {
.s identify 5 195
} {arrow2}
test scroll-3.48 {ScrollbarWidgetCmd procedure, "identify" option} {
.s identify 0 0
} {}
test scroll-3.49 {ScrollbarWidgetCmd procedure, "set" option} {
list [catch {.s set abc def} msg] $msg
} {1 {expected floating-point number but got "abc"}}
test scroll-3.50 {ScrollbarWidgetCmd procedure, "set" option} {
list [catch {.s set 0.6 def} msg] $msg
} {1 {expected floating-point number but got "def"}}
test scroll-3.51 {ScrollbarWidgetCmd procedure, "set" option} {
.s set -.2 .3
.s get
} {0.0 0.3}
test scroll-3.52 {ScrollbarWidgetCmd procedure, "set" option} {
.s set 1.1 .4
.s get
} {1.0 1.0}
test scroll-3.53 {ScrollbarWidgetCmd procedure, "set" option} {
.s set .5 -.3
.s get
} {0.5 0.5}
test scroll-3.54 {ScrollbarWidgetCmd procedure, "set" option} {
.s set .5 87
.s get
} {0.5 1.0}
test scroll-3.55 {ScrollbarWidgetCmd procedure, "set" option} {
.s set .4 .3
.s get
} {0.4 0.4}
test scroll-3.56 {ScrollbarWidgetCmd procedure, "set" option} {
list [catch {.s set abc def ghi jkl} msg] $msg
} {1 {expected integer but got "abc"}}
test scroll-3.57 {ScrollbarWidgetCmd procedure, "set" option} {
list [catch {.s set 1 def ghi jkl} msg] $msg
} {1 {expected integer but got "def"}}
test scroll-3.58 {ScrollbarWidgetCmd procedure, "set" option} {
list [catch {.s set 1 2 ghi jkl} msg] $msg
} {1 {expected integer but got "ghi"}}
test scroll-3.59 {ScrollbarWidgetCmd procedure, "set" option} {
list [catch {.s set 1 2 3 jkl} msg] $msg
} {1 {expected integer but got "jkl"}}
test scroll-3.60 {ScrollbarWidgetCmd procedure, "set" option} {
.s set -10 50 20 30
.s get
} {0 50 0 0}
test scroll-3.61 {ScrollbarWidgetCmd procedure, "set" option} {
.s set 100 -10 20 30
.s get
} {100 0 20 30}
test scroll-3.62 {ScrollbarWidgetCmd procedure, "set" option} {
.s set 100 50 30 20
.s get
} {100 50 30 30}
test scroll-3.63 {ScrollbarWidgetCmd procedure, "set" option} {
list [catch {.s set 1 2 3} msg] $msg
} {1 {wrong # args: should be ".s set firstFraction lastFraction" or ".s set totalUnits windowUnits firstUnit lastUnit"}}
test scroll-3.64 {ScrollbarWidgetCmd procedure, "set" option} {
list [catch {.s set 1 2 3 4 5} msg] $msg
} {1 {wrong # args: should be ".s set firstFraction lastFraction" or ".s set totalUnits windowUnits firstUnit lastUnit"}}
test scroll-3.65 {ScrollbarWidgetCmd procedure} {
list [catch {.s bogus} msg] $msg
} {1 {bad option "bogus": must be activate, cget, configure, delta, fraction, get, identify, or set}}
test scroll-3.66 {ScrollbarWidgetCmd procedure} {
list [catch {.s c} msg] $msg
} {1 {bad option "c": must be activate, cget, configure, delta, fraction, get, identify, or set}}
test scroll-4.1 {ScrollbarEventProc procedure} {
catch {destroy .s1}
scrollbar .s1 -bg #543210
rename .s1 .s2
set x {}
lappend x [winfo exists .s1]
lappend x [.s2 cget -bg]
destroy .s1
lappend x [info command .s?] [winfo exists .s1] [winfo exists .s2]
} {1 #543210 {} 0 0}
test scroll-5.1 {ScrollbarCmdDeletedProc procedure} {
catch {destroy .s1}
scrollbar .s1
rename .s1 {}
list [info command .s?] [winfo exists .s1]
} {{} 0}
catch {destroy .s}
scrollbar .s -orient vertical -relief sunken
pack .s -side right -fill y
.s set .2 .4
update
test scroll-6.1 {ScrollbarPosition procedure} {
.s identify 8 3
} {}
test scroll-6.2 {ScrollbarPosition procedure} {
.s identify 8 4
} {arrow1}
test scroll-6.3 {ScrollbarPosition procedure} {
.s identify 8 19
} {arrow1}
test scroll-6.4 {ScrollbarPosition procedure} {
.s identify 8 20
} {trough1}
test scroll-6.5 {ScrollbarPosition procedure} {nonPortable} {
# Don't know why this is non-portable, but it doesn't work on
# some platforms.
.s identify 8 51
} {trough1}
test scroll-6.6 {ScrollbarPosition procedure} {
.s identify 8 52
} {slider}
test scroll-6.7 {ScrollbarPosition procedure} {nonPortable} {
# Don't know why this is non-portable, but it doesn't work on
# some platforms.
.s identify 8 83
} {slider}
test scroll-6.8 {ScrollbarPosition procedure} {
.s identify 8 84
} {trough2}
test scroll-6.9 {ScrollbarPosition procedure} {
.s identify 8 179
} {trough2}
test scroll-6.10 {ScrollbarPosition procedure} {
.s identify 8 180
} {arrow2}
test scroll-6.11 {ScrollbarPosition procedure} {
.s identify 8 195
} {arrow2}
test scroll-6.12 {ScrollbarPosition procedure} {
.s identify 8 196
} {}
test scroll-6.13 {ScrollbarPosition procedure} {
.s identify 3 100
} {}
test scroll-6.14 {ScrollbarPosition procedure} {
.s identify 4 100
} {trough2}
test scroll-6.15 {ScrollbarPosition procedure} {
.s identify 18 100
} {trough2}
test scroll-6.16 {ScrollbarPosition procedure} {
.s identify 19 100
} {}
catch {destroy .t}
toplevel .t -width 250 -height 150
wm geometry .t +0+0
scrollbar .t.s -orient horizontal -relief sunken
place .t.s -width 200
.t.s set .2 .4
update
test scroll-6.17 {ScrollbarPosition procedure} {
.t.s identify 4 8
} {arrow1}
test scroll-6.18 {ScrollbarPosition procedure} {
.t.s identify 82 8
} {slider}
test scroll-6.19 {ScrollbarPosition procedure} {
.t.s identify 100 18
} {trough2}
catch {destroy .s}
catch {destroy .t}
concat {}