# Commands covered: treectrl
#
# This file contains a collection of tests for the treectrl command of
# the tktreectrl extension. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 2000 by Scriptics Corporation.
# Copyright (c) 2002 by Christian Krone.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import ::tcltest::*
}
package require Tk
package require treectrl
test treectrl-1.1 {Usage} -body {
treectrl
} -returnCodes error -result {wrong # args: should be "treectrl pathName ?options?"}
test treectrl-1.2 {Unknown option} -body {
treectrl .t -foo bar
} -returnCodes error -result {unknown option "-foo"}
test treectrl-1.3 {Create a tree} -body {
# The default borderwidth in Tk 8.4 is "2" while in Tk 8.5 it is "1"
# The default highlightthickness is "0" Mac OS X but "1" on other platforms.
treectrl .t -borderwidth 1 -highlightthickness 1
} -result {.t}
test treectrl-1.4 {configure: List all options} -body {
.t configure
} -result {{-background background Background white *}*} -match glob
test treectrl-1.5 {configure -background with totally empty visible tree} -body {
pack .t -expand yes -fill both
update
.t configure -background white
update idletasks
} -result {}
test treectrl-1.6 {configure: -background option} -body {
.t configure -background yellow
.t configure -background
} -result {-background background Background white yellow}
test treectrl-1.7 {configure: invalid -backgroundmode option} -body {
.t configure -backgroundmode foo
} -returnCodes error -result {bad backgroundmode "foo": must be column, order, ordervisible, row, index, or visindex}
test treectrl-1.8 {configure: -backgroundmode option} -body {
.t configure -backgroundmode column
.t configure -backgroundmode
} -result {-backgroundmode backgroundMode BackgroundMode row column}
test treectrl-1.9 {configure: invalid -buttonsize option} -body {
.t configure -buttonsize foo
} -returnCodes error -result {bad screen distance "foo"}
test treectrl-1.10 {configure: -buttonsize option} -body {
.t configure -buttonsize 1c
.t configure -buttonsize
} -result {-buttonsize buttonSize ButtonSize 9 1c}
test treectrl-1.11 {configure: invalid -buttoncolor option} -body {
.t configure -buttoncolor foo
} -returnCodes error -result {unknown color name "foo"}
test treectrl-1.12 {configure: -buttoncolor option} -body {
.t configure -buttoncolor red
.t configure -buttoncolor
} -result {-buttoncolor buttonColor ButtonColor #808080 red}
test treectrl-1.13 {configure: invalid -buttonbitmap option} -body {
.t configure -buttonbitmap no-such-bitmap
} -returnCodes error -result {bitmap "no-such-bitmap" not defined}
test treectrl-1.14 {configure: -buttonbitmap option} -body {
.t configure -buttonbitmap hourglass
.t configure -buttonbitmap
} -result {-buttonbitmap buttonBitmap ButtonBitmap {} hourglass}
test treectrl-1.17 {configure: invalid -buttonimage option} -body {
.t configure -buttonimage foo
} -returnCodes error -result {image "foo" doesn't exist}
test treectrl-1.18 {configure: -buttonimage option} -body {
image create photo emptyImg
.t configure -buttonimage emptyImg
.t configure -buttonimage
} -result {-buttonimage buttonImage ButtonImage {} emptyImg}
test treectrl-1.21 {configure: invalid -doublebuffer option} -body {
.t configure -doublebuffer foo
} -returnCodes error -result {bad doublebuffer "foo": must be none, item, or window}
test treectrl-1.22 {configure: -doublebuffer option} -body {
.t configure -doublebuffer window
.t configure -doublebuffer
} -result {-doublebuffer doubleBuffer DoubleBuffer item window}
test treectrl-1.23 {configure: invalid -indent option} -body {
.t configure -indent foo
} -returnCodes error -result {bad screen distance "foo"}
test treectrl-1.24 {configure: -indent option} -body {
.t configure -indent 2c
.t configure -indent
} -result {-indent indent Indent 19 2c}
test treectrl-1.25 {configure: invalid -itemheight option} -body {
.t configure -itemheight foo
} -returnCodes error -result {bad screen distance "foo"}
test treectrl-1.26 {configure: -itemheight option} -body {
.t configure -itemheight 18m
.t configure -itemheight
} -result {-itemheight itemHeight ItemHeight 0 18m}
test treectrl-1.27 {configure: invalid -linestyle option} -body {
.t configure -linestyle foo
} -returnCodes error -result {bad linestyle "foo": must be dot or solid}
test treectrl-1.28 {configure: -linestyle option} -body {
.t configure -linestyle solid
.t configure -linestyle
} -result {-linestyle lineStyle LineStyle dot solid}
test treectrl-1.29 {configure: invalid -linethickness option} -body {
.t configure -linethickness foo
} -returnCodes error -result {bad screen distance "foo"}
test treectrl-1.30 {configure: -linethickness option} -body {
.t configure -linethickness 3m
.t configure -linethickness
} -result {-linethickness lineThickness LineThickness 1 3m}
test treectrl-1.31 {configure: invalid -linecolor option} -body {
.t configure -linecolor #foo
} -returnCodes error -result {invalid color name "#foo"}
test treectrl-1.32 {configure: -linethickness option} -body {
.t configure -linecolor gray20
.t configure -linecolor
} -result {-linecolor lineColor LineColor #808080 gray20}
test treectrl-1.33 {configure: invalid -orient option} -body {
.t configure -orient foo
} -returnCodes error -result {bad orient "foo": must be horizontal or vertical}
test treectrl-1.34 {configure: -orient option} -body {
.t configure -orient h
.t configure -orient
} -result {-orient orient Orient vertical horizontal}
test treectrl-1.35 {configure: invalid -relief option} -body {
.t configure -relief foo
} -returnCodes error -result {bad relief "foo": must be flat, groove, raised, ridge, solid, or sunken}
test treectrl-1.36 {configure: -relief option} -body {
.t configure -relief flat
.t configure -relief
} -result {-relief relief Relief sunken flat}
test treectrl-1.37 {configure: invalid -showbuttons option} -body {
.t configure -showbuttons foo
} -returnCodes error -result {expected boolean value but got "foo"}
test treectrl-1.38 {configure: -showbuttons option} -body {
.t configure -showbuttons off
.t configure -showbuttons
} -result {-showbuttons showButtons ShowButtons 1 0}
test treectrl-1.39 {configure: invalid -showheader option} -body {
.t configure -showheader foo
} -returnCodes error -result {expected boolean value but got "foo"}
test treectrl-1.40 {configure: -showheader option} -body {
.t configure -showheader off
.t configure -showheader
} -result {-showheader showHeader ShowHeader 1 0}
test treectrl-1.41 {configure: invalid -showlines option} -body {
.t configure -showlines foo
} -returnCodes error -result {expected boolean value but got "foo"}
test treectrl-1.42 {configure: -showlines option} -body {
.t configure -showlines false
.t configure -showlines
} -result {-showlines showLines ShowLines * 0} -match glob
test treectrl-1.43 {configure: invalid -showroot option} -body {
.t configure -showroot foo
} -returnCodes error -result {expected boolean value but got "foo"}
test treectrl-1.44 {configure: -showroot option} -body {
.t configure -showroot no
.t configure -showroot
} -result {-showroot showRoot ShowRoot 1 0}
test treectrl-1.45 {configure: invalid -showrootbutton option} -body {
.t configure -showrootbutton foo
} -returnCodes error -result {expected boolean value but got "foo"}
test treectrl-1.46 {configure: -showrootbutton option} -body {
.t configure -showrootbutton True
.t configure -showrootbutton
} -result {-showrootbutton showRootButton ShowRootButton 0 1}
test treectrl-1.47 {configure: invalid -treecolumn option} -body {
.t configure -treecolumn foo
} -returnCodes error -result {column "foo" doesn't exist}
test treectrl-1.49 {configure: -treecolumn option with known column} -body {
.t column create -tag column0
.t column create -tag column2
.t configure -treecolumn 1
.t configure -treecolumn
} -result {-treecolumn treeColumn TreeColumn {} 1}
test treectrl-1.50 {configure: invalid -wrap mode} -body {
.t configure -wrap foo
} -returnCodes error -result {bad wrap "foo"}
test treectrl-1.51 {configure: invalid -wrap option: bogus width} -body {
.t configure -wrap {item bar}
} -returnCodes error -result {bad wrap "item bar"}
test treectrl-1.52 {configure: invalid -wrap option: superflous width} -body {
.t configure -wrap {1 window}
} -returnCodes error -result {bad wrap "1 window"}
test treectrl-1.53 {configure: -wrap option} -body {
.t configure -wrap {7 items}
.t configure -wrap
} -result {-wrap wrap Wrap {} {7 items}}
test treectrl-1.54 {configure: -wrap empty option} -body {
.t configure -wrap {}
.t configure -wrap
} -result {-wrap wrap Wrap {} {}}
# Before continuing to test the item descriptions and their modifiers,
# lets create some items with this hierarchy:
# 0
# + 1
# | + 2
# | + 3
# | + 4
# + 5
# | + 6
# | + 7
# + 8
test treectrl-2.16 {create some items} -body {
.t configure -showroot 1 -orient vertical
set n1 [.t item create]; .t item lastchild 0 $n1
set n2 [.t item create]; .t item lastchild $n1 $n2
set n3 [.t item create]; .t item lastchild $n1 $n3
set n4 [.t item create]; .t item lastchild $n3 $n4
set n5 [.t item create]; .t item lastchild 0 $n5
set n6 [.t item create]; .t item lastchild $n5 $n6
set n7 [.t item create]; .t item lastchild $n5 $n7
set n8 [.t item create]; .t item lastchild 0 $n8
} -result {8}
test treectrl-5.1 {state: missing args} -body {
.t state
} -returnCodes error -result {wrong # args: should be ".t state command ?arg arg ...?"}
test treectrl-5.2 {state: invalid command} -body {
.t state foo
} -returnCodes error -result {bad command "foo": must be *} -match glob
test treectrl-5.3 {state names: too many args} -body {
.t state names foo bar
} -returnCodes error -result {wrong # args: should be ".t state names"}
test treectrl-5.4 {state names: no states defined yet} -body {
.t state names
} -result {}
test treectrl-5.5 {state define: missing args} -body {
.t state define
} -returnCodes error -result {wrong # args: should be ".t state define stateName"}
test treectrl-5.6 {state define: overflow check} -body {
set msg ""
set ret 0
for {set ix 0} {$ix < 1000} {incr ix} {
set ret [catch {.t state define state$ix} msg]
if {$ret} {break}
}
list $ret $ix $msg
} -result {1 27 {cannot define any more states}}
test treectrl-5.7 {state names} -body {
.t state names
} -result {state0 state1 state2 state3 state4 state5 state6 state7 state8 state9 state10 state11 state12 state13 state14 state15 state16 state17 state18 state19 state20 state21 state22 state23 state24 state25 state26}
test treectrl-5.8 {state undefine: missing args is ok} -body {
.t state undefine
} -result {}
test treectrl-5.9 {state undefine: too many args} -body {
eval {.t state undefine} [lrange [.t state names] 3 end]
.t state names
} -result {state0 state1 state2}
test treectrl-5.10 {state undefine} -body {
foreach state [lrange [.t state names] 1 end] {
.t state undefine $state
}
.t state names
} -result {state0}
test treectrl-5.11 {state linkage: missing args} -body {
.t state linkage
} -returnCodes error -result {wrong # args: should be ".t state linkage state"}
test treectrl-5.12 {state linkage: unknown state} -body {
.t state linkage foo
} -returnCodes error -result {unknown state "foo"}
test treectrl-5.13 {state linkage: predefined state} -body {
.t state linkage open
} -result {static}
test treectrl-5.14 {state linkage: user defined state} -body {
.t state linkage state0
} -result {dynamic}
test treectrl-5.15 {state define: strange state name} -body {
.t state define ~user
} -returnCodes error -result {invalid state name "~user"}
test treectrl-5.17 {state define: strange state name} -body {
.t state linkage ~user
} -returnCodes error -result {can't specify '~' for this command}
test treectrl-5.18 {state undefine: strange state name} -body {
.t state undefine ~user
} -returnCodes error -result {can't specify '~' for this command}
test treectrl-5.19 {state define: strange state name} -body {
.t state define !WatchIt!
} -returnCodes error -result {invalid state name "!WatchIt!"}
test treectrl-5.20 {state define: strange state name} -body {
.t state define ""
} -returnCodes error -result {invalid state name ""}
test treectrl-7.0 {some prerequisites for the marquee test} -body {
.t element create eImage image -width 202 -height 18m
.t element create eRect rect -width 10c -height 18m
.t style create testStyle2
.t style elements testStyle2 {eImage eRect}
.t item style set 2
.t item style set 8 0 testStyle2
update idletasks
} -result {}
test treectrl-7.1 {marquee: missing args} -body {
.t marquee
} -returnCodes error -result {wrong # args: should be ".t marquee command ?arg arg ...?"}
test treectrl-7.2 {marquee: unknown command} -body {
.t marquee foo
} -returnCodes error -result {bad command "foo": must be *} -match glob
test treectrl-7.3 {marquee anchor: not yet modified} -body {
.t marquee anchor
} -result {0 0}
test treectrl-7.4 {marquee anchor: odd arguments} -body {
.t marquee anchor 1
} -returnCodes error -result {wrong # args: should be ".t marquee anchor ?x y?"}
test treectrl-7.5 {marquee identify: should be empty} -body {
.t marquee identify
} -result {}
test treectrl-7.6 {marquee anchor: set it} -body {
.t marquee anchor 5 5
} -result {}
test treectrl-7.7 {marquee coords: retrieve them} -body {
.t marquee coords
} -result {5 5 0 0}
test treectrl-7.8 {marquee identify: just the root} -body {
.t marquee identify
} -result {{0 0}}
test treectrl-7.9 {marquee corner: set it} -body {
.t marquee corner 600 600
.t marquee coords
} -result {5 5 600 600}
test treectrl-7.10 {marquee identify} -body {
.t marquee identify
} -result {{0 0} {1 0} {2 0} {3 0} {4 0} {5 0} {6 0} {7 0} {8 {0 eRect eImage}}}
test treectrl-7.11 {marquee identify: after invalid item style map} -body {
catch {.t item style map 1 0 noStyle {foo bar}}
.t marquee identify
} -result {{0 0} {1 0} {2 0} {3 0} {4 0} {5 0} {6 0} {7 0} {8 {0 eRect eImage}}}
test treectrl-7.12 {marquee visible} -body {
list [.t marquee configure -visible] \
[.t marquee cget -visible] \
[.t marquee configure -visible 1] \
[.t marquee cget -visible]
} -result {{-visible {} {} 0 0} 0 {} 1}
test treectrl-8.1 {selection: missing args} -body {
.t selection
} -returnCodes error -result {wrong # args: should be ".t selection command ?arg arg ...?"}
test treectrl-8.2 {selection: unknown command} -body {
.t selection foo
} -returnCodes error -result {bad command "foo": must be *} -match glob
test treectrl-8.3 {selection count/get: nothing selected yet} -body {
list [.t selection count] [.t selection get]
} -result {0 {}}
test treectrl-8.4 {selection anchor: always defined} -body {
.t selection anchor
} -result {0}
test treectrl-8.5 {selection anchor: modifies the anchor item} -body {
.t selection anchor "root lastchild"
.t item id anchor
} -result {8}
test treectrl-8.6 {selection count/get: still nothing selected} -body {
list [.t selection count] [.t selection get]
} -result {0 {}}
test treectrl-8.7 {selection add: all children of an item} -body {
.t selection add "1 firstchild" "1 lastchild"
list [.t selection count] [lsort -integer [.t selection get]]
} -result {2 {2 3}}
test treectrl-8.8 {selection add: all items and then some} -body {
.t selection add all "1 lastchild"
list [.t selection count] [lsort -integer [.t selection get]]
} -result {9 {0 1 2 3 4 5 6 7 8}}
test treectrl-8.9 {selection clear} -body {
.t selection add all
.t selection clear "root firstchild"
list [.t selection count] [lsort -integer [.t selection get]]
} -result {8 {0 2 3 4 5 6 7 8}}
test treectrl-8.10 {selection clear: some items and then all} -body {
.t selection clear "root lastchild" all
list [.t selection count] [.t selection get]
} -result {0 {}}
test treectrl-8.11 {selection modify: to be or not to be?} -body {
.t selection modify all all
list [.t selection count] [lsort -integer [.t selection get]]
} -result {9 {0 1 2 3 4 5 6 7 8}}
test treectrl-8.12 {selection clear: totally empty} -body {
.t selection clear
list [.t selection count] [lsort -integer [.t selection get]]
} -result {0 {}}
test treectrl-8.12 {selection modify: to be or not to be?} -body {
.t selection modify {{root firstchild} {root lastchild}} {{root lastchild}}
list [.t selection count] [lsort -integer [.t selection get]]
} -result {2 {1 8}}
test treectrl-8.13 {selection includes: missing args} -body {
.t selection includes
} -returnCodes error -result {wrong # args: should be ".t selection includes item"}
test treectrl-8.14 {selection includes: invalid item} -body {
.t selection includes {foo bar}
} -returnCodes error -result {item "foo bar" doesn't exist}
test treectrl-8.15 {selection includes: item is selected} -body {
.t selection includes {root child 2}
} -result {1}
test treectrl-8.16 {selection includes: item is not selected} -body {
.t selection includes {root child 0 firstchild}
} -result {0}
test treectrl-9.1 {see: missing args} -body {
.t see
} -returnCodes error -result {wrong # args: should be ".t see item ?column? ?option value ...?"}
test treectrl-9.2 {see: bogus option} -body {
.t see first -bar
} -returnCodes error -result {bad option "-bar": must be -center}
test treectrl-9.3 {see: invalid item} -body {
.t see foo
} -returnCodes error -result {item "foo" doesn't exist}
test treectrl-9.4 {see: bottom most item} -body {
.t see "root bottom"
} -result {}
test treectrl-9.5 {see: last item, bad column} -body {
.t see last foo
} -returnCodes error -result {column "foo" doesn't exist}
test treectrl-9.6 {see: missing option value} -body {
.t see first -center
} -returnCodes error -result {missing value for "-center" option}
test treectrl-9.7 {see: bogus option value} -body {
.t see first -center xz
} -returnCodes error -result {bad -center value "xz": *} -match glob
test treectrl-9.8 {see: -center xy} -body {
.t see first -center xy
} -result {}
test treectrl-10.1 {range: missing args} -body {
.t item range
} -returnCodes error -result {wrong # args: should be ".t item range first last"}
test treectrl-10.2 {range: too many args} -body {
.t item range foo bar baz
} -returnCodes error -result {wrong # args: should be ".t item range first last"}
test treectrl-10.3 {range: select all from top to bottom} -body {
.t item range "root top" "root bottom"
} -result {0 1 2 3 4 5 6 7 8}
test treectrl-10.4 {range: select all from bottom to top} -body {
.t item range "root bottom" "root top"
} -result {0 1 2 3 4 5 6 7 8}
test treectrl-11.1 {orphans: too many args} -body {
.t orphans foo
} -returnCodes error -result {wrong # args: should be ".t orphans"}
test treectrl-11.2 {orphans: lets make one} -body {
.t item remove 8
.t orphans
} -result {8}
test treectrl-11.3 {orphans: no orphans} -body {
.t item lastchild 0 8
.t orphans
} -result {}
test treectrl-12.1 {contentbox: too many args} -body {
.t contentbox foo
} -returnCodes error -result {wrong # args: should be ".t contentbox"}
test treectrl-12.2 {contentbox} -body {
.t contentbox
} -result {2 2 202 202}
test treectrl-12.3 {contentbox: simple double check with borders} -body {
expr {[lindex [.t contentbox] 0] \
== ([.t cget -bd]+[.t cget -highlightthickness])}
} -result {1}
test treectrl-12.4 {element delete while item is still displayed} -body {
.t element create elText text -text hallo
.t style create stText
.t style element stText elText
set new [.t item create]
.t item style set $new 0 stText
.t item lastchild 0 $new
.t element delete elText
place [frame .obscure] -in .t -relwidth 1.0 -relheight 1.0
update
destroy .obscure
update
} -result {}
test treectrl-13.1 {depth: too many args} -body {
.t depth foo bar
} -returnCodes error -result {wrong # args: should be ".t depth ?item?"}
test treectrl-13.2 {depth of the root item} -body {
.t depth root
} -result {0}
test treectrl-13.3 {depth of a deeper item} -body {
.t depth "root firstchild lastchild"
} -result {2}
test treectrl-13.4 {depth of the tree} -body {
.t depth
} -result {3}
test treectrl-13.5 {depth of the tree} -body {
.t depth
} -setup {
set rootKids [.t item children root]
foreach i $rootKids {.t item remove $i}
} -cleanup {
foreach i $rootKids {.t item lastchild root $i}
} -result {0}
test treectrl-14.1 {rename and change some columns} -body {
.t column delete column0
.t column create -tag column1
.t column create -tag column3
.t column move "order 0" "order 2"
.t column move "order 0" tail
.t element create eRect2 rect -fill blue -height 20 -width 150
.t style create testStyle3
.t style elements testStyle3 eRect2
.t item style set 1 column1 testStyle3
} -result {}
test treectrl-15.1 {identify: missing args} -body {
wm geometry . 400x200 ; update
.t identify
} -returnCodes error -result {wrong # args: should be ".t identify ?switches? x y"}
test treectrl-15.2 {identify: negative coords} -body {
.t configure -showheader 1 -showlines 1 -showbuttons 1 \
-borderwidth 2 -highlightthickness 1 -treecolumn 2 \
-itemheight 0 -linethickness 1 -indent 40
.t item configure 1 -button true
update idletasks
.t identify -5 -5
} -result {}
test treectrl-15.3 {identify: header left} -body {
# column 0 has width 0
# column 1 has width 0
# column 2 has width 40 + 40 + 150 = 230
# borders are 2 + 1 = 3
.t identify 3 4
} -result {header 2 left}
test treectrl-15.4 {identify: header} -body {
.t identify 40 4
} -result {header 2}
test treectrl-15.5 {identify: header right} -body {
.t identify 232 4
} -result {header 2 right}
test treectrl-15.6 {identify: tail left} -body {
.t identify 233 4
} -result {header tail left}
test treectrl-15.7 {identify: tail} -body {
.t identify 250 4
} -result {header tail}
test treectrl-15.8 {identify: item (to the left)} -body {
scan [.t bbox header] "%d %d %d %d" left top right bottom
.t identify 4 $bottom
} -result {item 1}
test treectrl-15.9 {identify: button} -body {
scan [.t bbox header] "%d %d %d %d" left top right bottom
.t identify 60 $bottom
} -result {item 1 button}
test treectrl-15.10 {identify: over element} -body {
scan [.t bbox header] "%d %d %d %d" left top right bottom
.t identify 150 $bottom
} -result {item 1 column 2 elem eRect2}
test treectrl-15.11 {identify: item (to the right)} -body {
# first make column wider, otherwise we can't get right of the item
.t column configure column1 -width 250
update idletasks
scan [.t bbox header] "%d %d %d %d" left top right bottom
.t identify 233 $bottom
} -result {item 1 column 2}
test treectrl-15.12 {identify: negative coords} -body {
.t column configure column1 -width ""
.t identify -array id -5 -5
parray id
} -output {id(where) =
} -cleanup {array unset id}
test treectrl-15.13 {identify: header left} -body {
# column 0 has width 0
# column 1 has width 0
# column 2 has width 40 + 40 + 150 = 230
# borders are 2 + 1 = 3
.t identify -array id 3 4
parray id
} -output {id(column) = 2
id(element) =
id(header) = 0
id(side) = left
id(where) = header
} -cleanup {array unset id}
test treectrl-15.14 {identify: header} -body {
.t identify -array id 40 4
parray id
} -output {id(column) = 2
id(element) =
id(header) = 0
id(side) =
id(where) = header
} -cleanup {array unset id}
test treectrl-15.15 {identify: header right} -body {
.t identify -array id 232 4
parray id
} -output {id(column) = 2
id(element) =
id(header) = 0
id(side) = right
id(where) = header
} -cleanup {array unset id}
test treectrl-15.16 {identify: tail left} -body {
.t identify -array id 233 4
parray id
} -output {id(column) = tail
id(element) =
id(header) = 0
id(side) = left
id(where) = header
} -cleanup {array unset id}
test treectrl-15.17 {identify: tail} -body {
.t identify -array id 250 4
parray id
} -output {id(column) = tail
id(element) =
id(header) = 0
id(side) =
id(where) = header
} -cleanup {array unset id}
test treectrl-15.18 {identify: item (to the left)} -body {
scan [.t bbox header] "%d %d %d %d" left top right bottom
.t identify -array id 4 $bottom
parray id
} -output {id(button) = no
id(column) = 2
id(element) =
id(item) = 1
id(line) =
id(where) = item
} -cleanup {array unset id}
test treectrl-15.19 {identify: button} -body {
scan [.t bbox header] "%d %d %d %d" left top right bottom
.t identify -array id 60 $bottom
parray id
} -output {id(button) = yes
id(column) = 2
id(element) =
id(item) = 1
id(line) =
id(where) = item
} -cleanup {array unset id}
test treectrl-15.20 {identify: over element} -body {
scan [.t bbox header] "%d %d %d %d" left top right bottom
.t identify -array id 150 $bottom
parray id
} -output {id(button) = no
id(column) = 2
id(element) = eRect2
id(item) = 1
id(line) =
id(where) = item
} -cleanup {array unset id}
test treectrl-15.21 {identify: item (to the right)} -body {
# first make column wider, otherwise we can't get right of the item
.t column configure column1 -width 250
update idletasks
scan [.t bbox header] "%d %d %d %d" left top right bottom
.t identify -array id 233 $bottom
parray id
} -output {id(button) = no
id(column) = 2
id(element) =
id(item) = 1
id(line) =
id(where) = item
} -cleanup {array unset id}
test treectrl-16.1 {dragimage: missing args} -body {
.t dragimage
} -returnCodes error -result {wrong # args: should be ".t dragimage command ?arg arg ...?"}
test treectrl-16.2 {dragimage: unknown command} -body {
.t dragimage foo
} -returnCodes error -result {bad command "foo": must be *} -match glob
test treectrl-16.3 {dragimage configure} -body {
.t dragimage configure
} -result {{-visible {} {} 0 0}}
test treectrl-16.4 {dragimage configure -visible} -body {
.t dragimage configure -visible
} -result {-visible {} {} 0 0}
test treectrl-16.5 {dragimage cget -visible} -body {
.t dragimage cget -visible
} -result {0}
test treectrl-16.6 {dragimage offset: without preceding add} -body {
.t dragimage offset
} -result {0 0}
test treectrl-16.7 {dragimage add: invalid item} -body {
.t dragimage add foo
} -returnCodes error -result {item "foo" doesn't exist}
test treectrl-16.8 {dragimage add: invalid column} -body {
.t dragimage add 1 foo
} -returnCodes error -result {column "foo" doesn't exist}
test treectrl-16.9 {dragimage add: invalid element} -body {
.t dragimage add 1 2 foo
} -returnCodes error -result {element "foo" doesn't exist}
test treectrl-16.10 {dragimage add: is still not visible} -body {
.t dragimage add 1 2
.t dragimage cget -visible
} -result {0}
test treectrl-16.11 {dragimage visible} -body {
.t dragimage configure -visible 1
.t dragimage cget -visible
} -result {1}
test treectrl-16.12 {dragimage offset} -body {
.t dragimage offset 10 10
.t dragimage offset
} -result {10 10}
test treectrl-16.13 {dragimage clear: too many args} -body {
.t dragimage clear 1
} -returnCodes error -result {wrong # args: should be ".t dragimage clear"}
test treectrl-16.14 {dragimage clear: doesn't modify the offset} -body {
.t dragimage clear
.t dragimage offset
} -result {10 10}
test treectrl-17.1 {columnproxy: Normally left blank} -body {
# BTW: This shouldn't be an option...
.t cget -columnproxy
} -result {}
test treectrl-17.2 {columnproxy: Normally left blank} -body {
.t configure -columnproxy foo
} -returnCodes error -result {bad screen distance "foo"}
test treectrl-17.3 {columnproxy: Negative screen distance} -body {
# It is unclear if this should be forbiden...
.t configure -columnproxy -1c
update idletasks
.t cget -columnproxy
} -result {-1c}
test treectrl-17.4 {columnproxy: screen distance bigger than width} -body {
# It is unclear if this should be forbiden...
set x [expr {[winfo width .t] + 10}]
.t configure -columnproxy $x
update idletasks
expr {[.t cget -columnproxy] == $x}
} -result {1}
test treectrl-17.5 {columnproxy} -body {
.t configure -columnproxy 100
update idletasks
.t cget -columnproxy
} -result {100}
test treectrl-18.1 {-defaultstyle: setup} -body {
.t column delete all
.t column create -tags a
.t column create -tags b
.t column create -tags c
.t column create -tags d
.t item delete all
.t style create a
.t style create b
.t style create c
.t style create d
} -result {d}
test treectrl-18.2 {-defaultstyle: set} -constraints {
deprecated
} -body {
.t configure -defaultstyle {a b c d}
.t cget -defaultstyle
} -result {a b c d}
test treectrl-18.3 {-defaultstyle: new items get default styles} -constraints {
deprecated
} -body {
set I [.t item create]
.t item style set $I
} -result {a b c d}
test treectrl-18.4 {-defaultstyle: moving column updates -defaultstyle} -constraints {
deprecated
} -body {
.t column move "tag a" "tag c"
.t cget -defaultstyle
} -result {b a c d}
test treectrl-18.5 {-defaultstyle: moving column updates -defaultstyle} -constraints {
deprecated
} -body {
.t column move "tag a" tail
.t cget -defaultstyle
} -result {b c d a}
test treectrl-18.6 {-defaultstyle: moving column updates -defaultstyle} -constraints {
deprecated
} -body {
.t column move "tag a" "tag b"
.t cget -defaultstyle
} -result {a b c d}
test treectrl-18.7 {-defaultstyle: moving column updates -defaultstyle} -constraints {
deprecated
} -body {
.t column create -tags e
.t column move "tag e" "tag d"
.t cget -defaultstyle
} -result {a b c {} d}
test treectrl-18.8 {-defaultstyle: moving column updates -defaultstyle} -constraints {
deprecated
} -body {
.t column create -tags f
.t column move "tag c" tail
.t cget -defaultstyle
} -result {a b {} d {} c}
test treectrl-18.9 {-defaultstyle: deleting column does not update -defaultstyle} -constraints {
deprecated
} -body {
.t column delete "tag e"
.t cget -defaultstyle
} -result {a b {} d {} c}
test treectrl-19.1 {gradient: missing args} -body {
.t gradient
} -returnCodes error -result {wrong # args: should be ".t gradient command ?arg arg ...?"}
test treectrl-19.3 {gradient: unknown command} -body {
.t gradient foo
} -returnCodes error -result {bad command "foo": must be *} -match glob
test treectrl-19.9 {gradient create: missing args} -body {
.t gradient create
} -returnCodes error -result {wrong # args: should be ".t gradient create name ?option value ...?"}
test treectrl-19.10 {gradient create: empty gradient name} -body {
.t gradient create ""
} -returnCodes error -result {invalid gradient name ""}
test treectrl-19.11 {gradient create: valid name} -body {
.t gradient create G1
} -result {G1}
test treectrl-19.12 {gradient create: duplicate name} -body {
.t gradient create G1
} -returnCodes error -result {gradient "G1" already exists}
test treectrl-19.13 {gradient create: missing argument option} -body {
.t gradient create G2 -stops
} -returnCodes error -result {value for "-stops" missing}
test treectrl-19.14 {gradient create: unknown option} -body {
.t gradient create G2 -foo
} -returnCodes error -result {unknown option "-foo"}
test treectrl-19.15 {gradient configure: missing args} -body {
.t gradient configure
} -returnCodes error -result {wrong # args: should be ".t gradient configure name ?option? ?value option value ...?"}
test treectrl-19.16 {gradient configure: unknown gradient} -body {
.t gradient configure foo
} -returnCodes error -result {gradient "foo" doesn't exist}
test treectrl-19.17 {gradient configure -steps: default} -body {
.t gradient configure G1 -steps
} -result {-steps {} {} 1 1}
test treectrl-19.18 {gradient configure -steps: invalid} -body {
.t gradient configure G1 -steps foo
} -returnCodes error -result {expected integer but got "foo"}
test treectrl-19.19 {gradient configure -steps: out of bounds} -body {
.t gradient configure G1 -steps 0
} -returnCodes error -result {steps must be >= 1 and <= 25}
test treectrl-19.20 {gradient configure -steps: out of bounds} -body {
.t gradient configure G1 -steps 100
} -returnCodes error -result {steps must be >= 1 and <= 25}
test treectrl-19.21 {gradient configure -steps: valid, lower limit} -body {
.t gradient configure G1 -steps 1
} -result {}
test treectrl-19.22 {gradient configure -steps: valid, upper limit} -body {
.t gradient configure G1 -steps 25
} -result {}
test treectrl-19.23 {gradient configure -stops: invalid} -body {
.t gradient configure G1 -stops foo
} -returnCodes error -result {at least 2 stops required, 1 given}
test treectrl-19.24 {gradient configure -stops: invalid} -body {
.t gradient configure G1 -stops {foo bar}
} -returnCodes error -result {stop list not {offset color ?opacity?}}
test treectrl-19.25 {gradient configure -stops: 0.0 must be first} -body {
.t gradient configure G1 -stops {{1.0 foo} {2.0 bar}}
} -returnCodes error -result {first stop offset must be 0.0, got 1}
test treectrl-19.26 {gradient configure -stops: unknown color} -body {
.t gradient configure G1 -stops {{0.0 foo} {2.0 bar}}
} -returnCodes error -result {unknown color name "foo"}
test treectrl-19.27 {gradient configure -stops: 1.0 must be last} -body {
.t gradient configure G1 -stops {{0.0 blue} {0.5 bar}}
} -returnCodes error -result {last stop offset must be 1.0, got 0.5}
test treectrl-19.28 {gradient configure -stops: must be ordered} -body {
.t gradient configure G1 -stops {{0.0 red} {0.5 green} {0.4 yellow} {1.0 blue}}
} -returnCodes error -result {stop offsets must be ordered}
test treectrl-20.1 {gradient coords: default} -body {
.t gradient configure G1 -left
} -result {-left {} {} {} {}}
test treectrl-20.2 {gradient coords: invalid} -body {
.t gradient configure G1 -left foo
} -returnCodes error -result {expected list {offset coordType ?arg ...?}}
test treectrl-20.3 {gradient coords: invalid} -body {
.t gradient configure G1 -left {a b}
} -returnCodes error -result {bad coordinate type "b": must be *} -match glob
test treectrl-20.4 {gradient coords: invalid} -body {
.t gradient configure G1 -left {a item}
} -returnCodes error -result {expected floating-point number but got "a"}
test treectrl-20.5 {gradient coords, area: missing arg} -body {
.t gradient configure G1 -left {0.5 area}
} -returnCodes error -result {wrong # args after "area": must be 1}
test treectrl-20.6 {gradient coords, area: too many args} -body {
.t gradient configure G1 -left {0.5 area a b}
} -returnCodes error -result {wrong # args after "area": must be 1}
test treectrl-20.7 {gradient coords, area: unknown area} -body {
.t gradient configure G1 -left {0.5 area foo}
} -returnCodes error -result {bad area "foo": must be *} -match glob
test treectrl-20.8 {gradient coords, area: valid} -body {
.t gradient configure G1 -left {0.5 area content}
} -result {}
test treectrl-20.9 {gradient coords, column: too many args} -body {
.t gradient configure G1 -left {0.5 column a b}
} -returnCodes error -result {wrong # args after "column": must be 0 or 1}
test treectrl-20.10 {gradient coords, column: invalid column} -body {
.t gradient configure G1 -left {0.5 column foo}
} -returnCodes error -result {column "foo" doesn't exist}
test treectrl-20.11 {gradient coords, column: valid w/o column} -body {
.t gradient configure G1 -left {0.5 column}
} -result {}
test treectrl-20.12 {gradient coords, column: valid w/ column} -body {
.t gradient configure G1 -left {0.5 column first}
} -result {}
test treectrl-20.13 {gradient coords, column: delete a column} -setup {
.t column create -tags C1
.t gradient configure G1 -left {0.5 column C1}
} -body {
.t column delete C1
.t gradient cget G1 -left
} -result {}
test treectrl-20.20 {gradient coords, item: too many args} -body {
.t gradient configure G1 -left {0.5 item a b}
} -returnCodes error -result {wrong # args after "item": must be 0 or 1}
test treectrl-20.21 {gradient coords, item: invalid item} -body {
.t gradient configure G1 -left {0.5 item foo}
} -returnCodes error -result {item "foo" doesn't exist}
test treectrl-20.22 {gradient coords, item: valid w/o item} -body {
.t gradient configure G1 -left {0.5 item}
} -result {}
test treectrl-20.23 {gradient coords, item: valid w/ item} -body {
.t gradient configure G1 -left {0.5 item first}
} -result {}
test treectrl-20.24 {gradient coords, item: delete an item} -setup {
.t item create -tags I1
.t gradient configure G1 -left {0.5 item I1}
} -body {
.t item delete I1
.t gradient cget G1 -left
} -result {}
test treectrl-21.1 {gradient delete: no args} -body {
.t gradient delete
} -result {}
test treectrl-21.2 {gradient delete: unknown gradient} -body {
.t gradient delete foo
} -returnCodes error -result {gradient "foo" doesn't exist}
test treectrl-21.3 {gradient delete: success} -body {
set result [.t gradient names]
.t gradient delete G1
lappend result [.t gradient names]
} -result {G1 {}}
test treectrl-21.4 {gradient delete: in use} -setup {
.t gradient create G1
.t column create -tags C1 -itembackground G1
} -body {
set result [.t gradient names]
.t gradient delete G1
lappend result [.t gradient names]
lappend result [.t column cget C1 -itembackground]
} -result {G1 {} G1}
test treectrl-21.5 {gradient delete: deleted gradient recreated} -body {
.t gradient create G1
.t gradient names
} -result {G1}
test treectrl-21.6 {gradient delete: deleted gradient no longer referenced} -setup {
.t gradient delete G1
.t column configure C1 -itembackground {}
} -body {
# now the gradient is freed
} -result {}
test treectrl-22.1 {gradient native: no args} -body {
string is boolean -strict [.t gradient native]
} -result {1}
test treectrl-22.2 {gradient native: too many args} -body {
.t gradient native foo bar
} -returnCodes error -result {wrong # args: should be ".t gradient native ?preference?"}
test treectrl-22.3 {gradient native: result doesn't change} -body {
set r1 [.t gradient native]
.t gradient native [expr {!$r1}]
set r2 [.t gradient native]
expr {$r1 eq $r2}
} -result {1}
test treectrl-99.1 {some needed cleanup} -body {
destroy .t
} -result {}
# cleanup
image delete emptyImg
::tcltest::cleanupTests
return