Pratt 1.5.6

data/pkgs/tile-0.8.2/tests/treetags.test

@@ -0,0 +1,78 @@
+#
+# treetags.test,v 1.2 2007/05/21 22:28:18 jenglish Exp
+#
+package require Tk
+package require tcltest ; namespace import -force tcltest::*
+loadTestedCommands
+tk useinputmethods 0
+
+set auto_path [linsert $auto_path 0 .] ; package require tile
+
+testConstraint nyi 0
+
+test treetags-1.0 "Setup" -body {
+    set tv [ttk::treeview .tv]
+    .tv insert {} end -id item1 -text "Item 1"
+    pack .tv 
+}
+
+test treetags-1.1 "Bad tag list" -body {
+    $tv item item1 -tags {bad {list}here bad}
+} -returnCodes error -result "list element in braces *" -match glob
+
+test treetags-1.2 "Good tag list" -body {
+    $tv item item1 -tags tag1
+    $tv item item1 -tags
+} -result [list tag1]
+
+test treetags-1.3 "Bad events" -body {
+    $tv tag bind bad <Enter> { puts "Entered!" }
+} -returnCodes 1 -result "unsupported event <Enter>*" -match glob
+
+test treetags-2.0 "tag bind" -body {
+    $tv tag bind tag1 <KeyPress> {set ::KEY %A}
+    $tv tag bind tag1 <KeyPress>
+} -result {set ::KEY %A}
+
+test treetags-2.1 "Events delivered to tags" -body {
+    focus -force $tv ; update	;# needed so [event generate] delivers KeyPress
+    $tv focus item1
+    event generate .tv <KeyPress-a>
+    set ::KEY
+} -result a
+
+test treetags-2.2 "Events delivered to correct tags" -body {
+    $tv insert {} end -id item2 -tags tag2
+    $tv tag bind tag2 <KeyPress> [list set ::KEY2 %A]
+
+    $tv focus item1
+    event generate $tv <KeyPress-b>
+    $tv focus item2
+    event generate $tv <KeyPress-c>
+
+    list $::KEY $::KEY2
+} -result [list b c]
+
+test treetags-2.3 "Virtual events delivered to focus item" -body {
+    set ::bong 0
+    $tv tag bind tag2 <<Bing>> { incr bong }
+    $tv focus item2
+    event generate $tv <<Bing>>
+    $tv focus item1
+    event generate $tv <<Bing>>
+    set bong
+} -result 1
+
+
+test treetags-3.0 "tag configure" -body {
+    $tv tag configure tag1 -foreground blue -background red
+} -result {}
+
+test treetags-3.1 "tag configure" -body {
+    $tv tag configure tag1 -foreground
+} -result [list blue]
+
+
+test treetags-end "Cleanup" -body { destroy .tv }
+
+tcltest::cleanupTests

data/pkgs/tile-0.8.2/tests/treeview.test

@@ -0,0 +1,563 @@
+#
+# treeview.test,v 1.9 2006/12/18 19:03:33 jenglish Exp
+#
+# [7Jun2005] TO CHECK: [$tv see {}] -- shouldn't work (at least, shouldn't do
+# what it currently does)
+#
+
+package require Tk
+package require tcltest ; namespace import -force tcltest::*
+loadTestedCommands
+
+lappend auto_path .
+package require tile
+
+# consistencyCheck --
+#	Traverse the tree to make sure the item data structures
+#	are properly linked.
+#
+#	Since [$tv children] follows ->next links and [$tv index]
+#	follows ->prev links, this should cover all invariants.
+#
+proc consistencyCheck {tv {item {}}} {
+    set i 0;
+    foreach child [$tv children $item] {
+	assert {[$tv parent $child] == $item} "parent $child = $item"
+	assert {[$tv index $child] == $i} "index $child [$tv index $child]=$i"
+	incr i
+	consistencyCheck $tv $child
+    }
+}
+
+proc assert {expr {message ""}} {
+    if {![uplevel 1 [list expr $expr]]} {
+        set error "PANIC! PANIC! PANIC: $message ($expr failed)"
+    	puts stderr $error
+	error $error
+    }
+}
+
+test treeview-0 "treeview test - setup" -body {
+    ttk::treeview .tv -columns {a b c}
+    pack .tv -expand true -fill both
+    update
+}
+
+test treeview-1.1 "columns" -body {
+    .tv configure -columns {a b c}
+}
+
+test treeview-1.2 "Bad columns" -body {
+    #.tv configure -columns {illegal "list"value}
+    ttk::treeview .badtv -columns {illegal "list"value}
+} -returnCodes 1 -result "list element in quotes followed by*" -match glob
+
+test treeview-1.3 "bad displaycolumns" -body {
+    .tv configure -displaycolumns {a b d}
+} -returnCodes 1 -result "Invalid column index d"
+
+test treeview-1.4 "more bad displaycolumns" -body {
+    .tv configure -displaycolumns {1 2 3}
+} -returnCodes 1 -result "Column index 3 out of bounds"
+
+test treeview-1.5 "Don't forget to check negative numbers" -body {
+    .tv configure -displaycolumns {1 -2 3}
+} -returnCodes 1 -result "Column index -2 out of bounds"
+
+# Item creation.
+#
+test treeview-2.1 "insert -- not enough args" -body {
+    .tv insert
+} -returnCodes 1 -result "wrong # args: *" -match glob
+
+test treeview-2.3 "insert -- bad integer index" -body {
+    .tv insert {} badindex
+} -returnCodes 1 -result "expected integer *" -match glob
+
+test treeview-2.4 "insert -- bad parent node" -body {
+    .tv insert badparent end
+} -returnCodes 1 -result "Item badparent not found" -match glob
+
+test treeview-2.5 "insert -- finaly insert a node" -body {
+    .tv insert {} end -id newnode -text "New node"
+} -result newnode
+
+test treeview-2.6 "insert -- make sure node was inserted" -body {
+    .tv children {}
+} -result [list newnode]
+
+test treeview-2.7 "insert -- prevent duplicate node names" -body {
+    .tv insert {} end -id newnode
+} -returnCodes 1 -result "Item newnode already exists"
+
+test treeview-2.8 "insert -- new node at end" -body {
+    .tv insert {} end -id lastnode
+    consistencyCheck .tv
+    .tv children {}
+} -result [list newnode lastnode]
+
+consistencyCheck .tv
+
+test treeview-2.9 "insert -- new node at beginning" -body {
+    .tv insert {} 0 -id firstnode
+    consistencyCheck .tv
+    .tv children {}
+} -result [list firstnode newnode lastnode]
+
+test treeview-2.10 "insert -- one more node" -body {
+    .tv insert {} 2 -id onemore
+    consistencyCheck .tv
+    .tv children {}
+} -result [list firstnode newnode onemore lastnode]
+
+test treeview-2.11 "insert -- and another one" -body {
+    .tv insert {} 2 -id anotherone
+    consistencyCheck .tv
+    .tv children {}
+} -result [list firstnode newnode anotherone onemore lastnode]
+
+test treeview-2.12 "insert -- one more at end" -body {
+    .tv insert {} end -id newlastone
+    consistencyCheck .tv
+    .tv children {}
+} -result [list firstnode newnode anotherone onemore lastnode newlastone]
+
+test treeview-2.13 "insert -- one more at beginning" -body {
+    .tv insert {} 0 -id newfirstone
+    consistencyCheck .tv
+    .tv children {}
+} -result [list newfirstone firstnode newnode anotherone onemore lastnode newlastone]
+
+test treeview-2.14 "insert -- bad options" -body {
+    .tv insert {} end -badoption foo
+} -returnCodes 1 -result {unknown option "-badoption"}
+
+test treeview-2.15 "insert -- at position 0 w/no children" -body {
+    .tv insert newnode 0 -id newnode.n2 -text "Foo"
+    .tv children newnode
+} -result newnode.n2	;# don't crash
+
+test treeview-2.16 "insert -- insert way past end" -body {
+    .tv insert newnode 99 -id newnode.n3 -text "Foo"
+    consistencyCheck .tv
+    .tv children newnode
+} -result [list newnode.n2 newnode.n3]
+
+test treeview-2.17 "insert -- insert before beginning" -body {
+    .tv insert newnode -1 -id newnode.n1 -text "Foo"
+    consistencyCheck .tv
+    .tv children newnode
+}  -result [list newnode.n1 newnode.n2 newnode.n3]
+
+###
+#
+test treeview-3.1 "parent" -body {
+    .tv parent newnode.n1
+} -result newnode
+test treeview-3.2 "parent - top-level node" -body {
+    .tv parent newnode
+} -result {}
+test treeview-3.3 "parent - root node" -body {
+    .tv parent {}
+} -result {}
+test treeview-3.4 "index" -body {
+    list [.tv index newnode.n3] [.tv index newnode.n2] [.tv index newnode.n1]
+} -result [list 2 1 0]
+test treeview-3.5 "index - exhaustive test" -body {
+    set result [list]
+    foreach item [.tv children {}] {
+	lappend result [.tv index $item]
+    }
+    set result
+} -result [list 0 1 2 3 4 5 6]
+
+test treeview-3.6 "detach" -body {
+    .tv detach newnode
+    consistencyCheck .tv
+    .tv children {}
+} -result [list newfirstone firstnode anotherone onemore lastnode newlastone]
+# XREF: treeview-2.13
+
+test treeview-3.7 "detach didn't screw up internal links" -body {
+    consistencyCheck .tv
+    set result [list]
+    foreach item [.tv children {}] {
+	lappend result [.tv index $item]
+    }
+    set result
+} -result [list 0 1 2 3 4 5]
+
+test treeview-3.8 "detached node has no parent, index 0" -body {
+    list [.tv parent newnode] [.tv index newnode]
+} -result [list {} 0]
+# @@@ Can't distinguish detached nodes from first root node
+
+test treeview-3.9 "detached node's children undisturbed" -body {
+    .tv children newnode
+} -result [list newnode.n1 newnode.n2 newnode.n3]
+
+test treeview-3.10 "detach is idempotent" -body {
+    .tv detach newnode
+    consistencyCheck .tv
+    .tv children {}
+} -result [list newfirstone firstnode anotherone onemore lastnode newlastone]
+
+test treeview-3.11 "Can't detach root item" -body {
+    .tv detach [list {}]
+    update
+    consistencyCheck .tv
+} -returnCodes 1 -result "Cannot detach root item"
+consistencyCheck .tv
+
+test treeview-3.12 "Reattach" -body {
+    .tv move newnode {} end
+    consistencyCheck .tv
+    .tv children {}
+} -result [list newfirstone firstnode anotherone onemore lastnode newlastone newnode]
+
+# Bug # ?????
+test treeview-3.13 "Re-reattach" -body {
+    .tv move newnode {} end
+    consistencyCheck .tv
+    .tv children {}
+} -result [list newfirstone firstnode anotherone onemore lastnode newlastone newnode]
+
+.tv insert newfirstone end -id x1
+.tv insert newfirstone end -id x2
+.tv insert newfirstone end -id x3
+
+test treeview-3.14 "Duplicated entry in children list" -body {
+    .tv children newfirstone [list x3 x1 x2 x3]
+    # ??? Maybe this should raise an error?
+    consistencyCheck .tv
+    .tv children newfirstone
+} -result [list x3 x1 x2]
+
+test treeview-3.14.1 "Duplicated entry in children list" -body {
+    .tv children newfirstone [list x1 x2 x3 x3 x2 x1]
+    consistencyCheck .tv
+    .tv children newfirstone
+} -result [list x1 x2 x3]
+
+test treeview-3.15 "Consecutive duplicate entries in children list" -body {
+    .tv children newfirstone [list x1 x2 x2 x3]
+    consistencyCheck .tv
+    .tv children newfirstone
+} -result [list x1 x2 x3]
+
+test treeview-3.16 "Insert child after self" -body {
+    .tv move x2 newfirstone 1 
+    consistencyCheck .tv
+    .tv children newfirstone
+} -result [list x1 x2 x3]
+
+test treeview-3.17 "Insert last child after self" -body {
+    .tv move x3 newfirstone 2
+    consistencyCheck .tv
+    .tv children newfirstone
+} -result [list x1 x2 x3]
+
+test treeview-3.18 "Insert last child after end" -body {
+    .tv move x3 newfirstone 3
+    consistencyCheck .tv
+    .tv children newfirstone
+} -result [list x1 x2 x3]
+
+
+test treeview-4.1 "opened - initial state" -body {
+    .tv item newnode -open
+} -result 0
+test treeview-4.2 "opened - open node" -body {
+    .tv item newnode -open 1
+    .tv item newnode -open
+} -result 1
+test treeview-4.3 "opened - closed node" -body {
+    .tv item newnode -open 0
+    .tv item newnode -open
+} -result 0
+
+test treeview-5.1 "item -- error checks" -body {
+    .tv item newnode -text "Bad values" -values "{bad}list"
+} -returnCodes 1 -result "list element in braces followed by*" -match glob
+
+test treeview-5.2 "item -- error leaves options unchanged " -body {
+    .tv item newnode -text
+} -result "New node"
+
+test treeview-5.3 "Heading" -body {
+    .tv heading #0 -text "Heading"
+}
+
+test treeview-5.4 "get cell" -body {
+    set l [list a b c]
+    .tv item newnode -values $l
+    .tv set newnode 1 
+} -result b
+
+test treeview-5.5 "set cell" -body {
+    .tv set newnode 1 XXX
+    .tv item newnode -values 
+} -result [list a XXX c]
+
+test treeview-5.6 "set illegal cell" -body {
+    .tv set newnode #0 YYY
+} -returnCodes 1 -result "Display column #0 cannot be set"
+
+test treeview-5.7 "set illegal cell" -body {
+    .tv set newnode 3 YY	;# 3 == current #columns
+} -returnCodes 1 -result "Column index 3 out of bounds"
+
+test treeview-5.8 "set display columns" -body {
+    .tv configure -displaycolumns [list 2 1 0]
+    .tv set newnode #1 X
+    .tv set newnode #2 Y
+    .tv set newnode #3 Z
+    .tv item newnode -values
+} -result [list Z Y X]
+
+test treeview-5.9 "display columns part 2" -body {
+    list [.tv column #1 -id] [.tv column #2 -id] [.tv column #3 -id]
+} -result [list c b a]
+
+test treeview-5.10 "cannot set column -id" -body {
+    .tv column #1 -id X
+} -returnCodes 1 -result "Attempt to change read-only option"
+
+test treeview-5.11 "get" -body {
+    .tv set newnode #1
+} -result X
+
+test treeview-5.12 "get dictionary" -body {
+    .tv set newnode
+} -result [list a Z b Y c X]
+
+test treeview-5.13 "get, no value" -body {
+    set newitem [.tv insert {} end]
+    set result [.tv set $newitem #1]
+    .tv delete $newitem
+    set result
+} -result {}
+
+test treeview-5.14 "-displaycolumns #all" -body {
+    .tv configure -displaycolumns "#all" 
+    list [.tv column #1 -id] [.tv column #2 -id] [.tv column #3 -id]
+} -result [.tv cget -columns]
+
+test treeview-5.15 "-displaycolumns empty" -body {
+    .tv configure -displaycolumns [list]
+    list [.tv column #1 -id] [.tv column #2 -id] [.tv column #3 -id]
+} -returnCodes error -result "Column #1 out of range"
+
+test treeview-6.1 "deletion - setup" -body {
+    .tv insert {} end -id dtest
+    foreach id [list a b c d e] {
+	.tv insert dtest end -id $id
+    }
+    .tv children dtest
+} -result [list a b c d e]
+
+test treeview-6.1 "delete" -body {
+    .tv delete b
+    consistencyCheck .tv
+    list [.tv exists b] [.tv children dtest]
+} -result [list 0 [list a c d e]]
+
+consistencyCheck .tv
+
+test treeview-6.2 "delete - duplicate items in list" -body {
+    .tv delete [list a e a e]
+    consistencyCheck .tv
+    .tv children dtest
+} -result [list c d]
+
+test treeview-6.3 "delete - descendants removed" -body {
+    .tv insert c  end -id c1
+    .tv insert c  end -id c2
+    .tv insert c1 end -id c11
+    consistencyCheck .tv
+    .tv delete c
+    consistencyCheck .tv
+    list [.tv exists c] [.tv exists c1] [.tv exists c2] [.tv exists c11]
+} -result [list 0 0 0 0]
+
+test treeview-6.4 "delete - delete parent and descendants" -body {
+    .tv insert dtest end -id c
+    .tv insert c  end -id c1
+    .tv insert c  end -id c2
+    .tv insert c1 end -id c11
+    consistencyCheck .tv
+    .tv delete [list c c1 c2 c11]
+    consistencyCheck .tv
+    list [.tv exists c] [.tv exists c1] [.tv exists c2] [.tv exists c11]
+} -result [list 0 0 0 0]
+
+test treeview-6.5 "delete - delete descendants and parent" -body {
+    .tv insert dtest end -id c
+    .tv insert c  end -id c1
+    .tv insert c  end -id c2
+    .tv insert c1 end -id c11
+    consistencyCheck .tv
+    .tv delete [list c11 c1 c2 c]
+    consistencyCheck .tv
+    list [.tv exists c] [.tv exists c1] [.tv exists c2] [.tv exists c11]
+} -result [list 0 0 0 0]
+
+test treeview-6.6 "delete - end" -body {
+    consistencyCheck .tv
+    .tv children dtest
+} -result [list d]
+
+test treeview-7.1 "move" -body {
+    .tv insert d end -id d1
+    .tv insert d end -id d2
+    .tv insert d end -id d3
+    .tv move d3 d 0
+    consistencyCheck .tv
+    .tv children d
+} -result [list d3 d1 d2]
+
+test treeview-7.2 "illegal move" -body {
+   .tv move d d2 end
+} -returnCodes 1 -result "Cannot insert d as a descendant of d2" 
+
+test treeview-7.3 "illegal move has no effect" -body {
+    consistencyCheck .tv
+    .tv children d 
+} -result [list d3 d1 d2]
+
+test treeview-7.4 "Replace children" -body {
+    .tv children d [list d3 d2 d1]
+    consistencyCheck .tv
+    .tv children d
+} -result [list d3 d2 d1]
+
+test treeview-7.5 "replace children - precondition" -body {
+    # Just check to make sure the test suite so far has left
+    # us in the state we expect to be in:
+    list [.tv parent newnode] [.tv children newnode]
+} -result [list {} [list newnode.n1 newnode.n2 newnode.n3]]
+
+test treeview-7.6 "Replace children - illegal move" -body {
+    .tv children newnode.n1 [list newnode.n1 newnode.n2 newnode.n3]
+} -returnCodes 1 -result "Cannot insert newnode.n1 as a descendant of newnode.n1"
+
+proc lmove {l from to} {
+    linsert [lreplace $l $from $from] $to [lindex $l $from]
+}
+
+test treeview-7.7 "Exhaustive moves" -setup {
+    set r [.tv insert newnode 0]
+    set l [list m1 m2 m3 m4 m5]
+    foreach c $l {
+	.tv insert $r end -id $c
+    }
+} -cleanup {
+    .tv delete $r
+} -body {
+    set n [llength $l]
+    set errors [list]
+    for {set i 0} {$i < $n} {incr i} {
+	for {set j 0} {$j < $n} {incr j} {
+
+	    .tv children $r $l			; consistencyCheck .tv
+	    .tv move [lindex $l $i] $r $j	; consistencyCheck .tv
+
+	    set expect [lmove $l $i $j]
+	    set result [.tv children $r]
+	    foreach x $expect y $result {
+		if {$x ne $y} {
+		    lappend errors \
+		    	"move $i -> $j: got '$result', expected '$expect'"
+		    break;
+		}
+	    }
+	}
+    }
+    join $errors \n
+} -result ""
+
+test treeview-7.8 "Exhaustive inserts" -setup {
+    set r [.tv insert newnode 0]
+    set l [list i1 i2 i3 i4]
+    foreach c $l {
+	.tv insert $r end -id $c
+    }
+} -cleanup {
+    .tv delete $r
+} -body {
+    set n [llength $l]
+    set errors [list]
+    for {set i -1} {$i <= $n+1} {incr i} {
+	consistencyCheck .tv
+
+	.tv insert $r $i -id X 		; consistencyCheck .tv
+	set expect [linsert $l $i X]
+	set result [.tv children $r]
+	foreach x $expect y $result {
+	    if {$x ne $y} {
+		lappend errors "insert $i: got '$result', expected '$expect'"
+		break;
+	    }
+	}
+	.tv delete X			; consistencyCheck .tv
+    }
+    join $errors \n
+} -result ""
+consistencyCheck .tv
+
+test treeview-8.0 "Selection set" -body {
+    .tv selection set [list newnode.n1 newnode.n3 newnode.n2]
+    .tv selection
+} -result [list newnode.n1 newnode.n2 newnode.n3]
+
+test treeview-8.1 "Selection add" -body {
+    .tv selection add [list newnode]
+    .tv selection
+} -result [list newnode newnode.n1 newnode.n2 newnode.n3]
+
+test treeview-8.2 "Selection toggle" -body {
+    .tv selection toggle [list newnode.n2 d3]
+    .tv selection
+} -result [list newnode newnode.n1 newnode.n3 d3]
+
+test treeview-8.3 "Selection remove" -body {
+    .tv selection remove [list newnode.n2 d3]
+    .tv selection
+} -result [list newnode newnode.n1 newnode.n3]
+
+test treeview-8.4 "Selection - clear" -body {
+    .tv selection set {}
+    .tv selection
+} -result {}
+
+test treeview-8.5 "Selection - bad operation" -body {
+    .tv selection badop foo
+} -returnCodes 1 -match glob -result {bad selection operation "badop": must be *}
+
+### NEED: more tests for see/yview/scrolling
+
+proc scrollcallback {args} {
+    set ::scrolldata $args
+}
+test treeview-9.0 "scroll callback - empty tree" -body {
+    .tv configure -yscrollcommand scrollcallback
+    .tv delete [.tv children {}]
+    update
+    set ::scrolldata
+} -result [list 0 1]
+
+### NEED: tests for focus item, selection
+
+
+### Misc. tests:
+
+destroy .tv
+test treeview-10.1 "Root node properly initialized (#1541739)" -setup {
+    ttk::treeview .tv
+    .tv insert {} end -id a
+    .tv see a
+} -cleanup {
+    destroy .tv
+}
+
+tcltest::cleanupTests