Pratt 1.5.6

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

@@ -0,0 +1,285 @@
+#
+# ttk::entry widget tests
+#
+
+package require Tk
+package require tcltest ; namespace import -force tcltest::*
+loadTestedCommands
+
+lappend auto_path .
+package require tile
+
+variable scrollInfo
+proc scroll args {
+    global scrollInfo
+    set scrollInfo $args
+}
+
+# Some of the tests raise background errors;
+# override default bgerror to catch them.
+#
+variable bgerror ""
+proc bgerror {error} {
+    variable bgerror $error
+    variable bgerrorInfo $::errorInfo
+    variable bgerrorCode $::errorCode
+}
+
+#
+test entry-1.1 "Create entry widget" -body {
+    ttk::entry .e
+} -result .e
+
+test entry-1.2 "Insert" -body {
+    .e insert end abcde
+    .e get
+} -result abcde
+
+test entry-1.3 "Selection" -body {
+    .e selection range 1 3
+    selection get
+} -result bc
+
+test entry-1.4 "Delete" -body {
+    .e delete 1 3
+    .e get
+} -result ade
+
+test entry-1.5 "Deletion - insert cursor" -body {
+    .e insert end abcde
+    .e icursor 0
+    .e delete 0 end
+    .e index insert
+} -result 0
+
+test entry-1.6 "Deletion - insert cursor at end" -body {
+    .e insert end abcde
+    .e icursor end
+    .e delete 0 end
+    .e index insert
+} -result 0
+
+test entry-1.7 "Deletion - insert cursor in the middle " -body {
+    .e insert end abcde
+    .e icursor 3
+    .e delete 0 end
+    .e index insert
+} -result 0
+
+test entry-1.done "Cleanup" -body { destroy .e }
+
+# Scrollbar tests.
+
+test entry-2.1 "Create entry before scrollbar" -body {
+    pack [ttk::entry .te -xscrollcommand [list .tsb set]] \
+	-expand true -fill both
+    pack [ttk::scrollbar .tsb -orient horizontal -command [list .te xview]] \
+    	-expand false -fill x
+}  -cleanup {destroy .te .tsb}
+
+test entry-2.2 "Initial scroll position" -body {
+    ttk::entry .e -font fixed -width 5 -xscrollcommand scroll
+    .e insert end "0123456789"
+    pack .e; update
+    set scrollInfo
+} -result {0 0.5} -cleanup { destroy .e }
+# NOTE: result can vary depending on font.
+
+# Bounding box / scrolling tests.
+test entry-3.0 "Series 3 setup" -body {
+    ttk::style theme use default
+    variable fixed fixed
+    variable cw [font measure $fixed a]
+    variable ch [font metrics $fixed -linespace]
+    variable bd 2	;# border + padding
+    variable ux [font measure $fixed \u4e4e]
+
+    pack [ttk::entry .e -font $fixed -width 20]
+    update
+}
+
+test entry-3.1 "bbox widget command" -body {
+    .e delete 0 end
+    .e bbox 0
+} -result [list $bd $bd 0 $ch]
+
+test entry-3.2 "xview" -body {
+    .e delete 0 end;
+    .e insert end [string repeat "0" 40]
+    update idletasks
+    set result [.e xview]
+} -result {0 0.5}
+
+test entry-3.last "Series 3 cleanup" -body {
+    destroy .e
+}
+
+# Selection tests:
+
+test entry-4.0 "Selection test - setup" -body {
+    ttk::entry .e
+    .e insert end asdfasdf
+    .e selection range 0 end
+}
+
+test entry-4.1 "Selection test" -body {
+    selection get
+} -result asdfasdf
+
+test entry-4.2 "Disable -exportselection" -body {
+    .e configure -exportselection false
+    selection get
+} -returnCodes error -result "PRIMARY selection doesn't exist*" -match glob
+
+test entry-4.3 "Reenable -exportselection" -body {
+    .e configure -exportselection true
+    selection get
+} -result asdfasdf
+
+test entry-4.4 "Force selection loss" -body {
+    selection own .
+    .e index sel.first
+} -returnCodes error -result "selection isn't in widget .e"
+
+test entry-4.5 "Allow selection changes if readonly" -body {
+    .e delete 0 end
+    .e insert end 0123456789
+    .e selection range 0 end
+    .e configure -state readonly
+    .e selection range 2 4
+    .e configure -state normal
+    list [.e index sel.first] [.e index sel.last]
+} -result {2 4}
+
+test entry-4.6 "Disallow selection changes if disabled" -body {
+    .e delete 0 end
+    .e insert end 0123456789
+    .e selection range 0 end
+    .e configure -state disabled
+    .e selection range 2 4
+    .e configure -state normal
+    list [.e index sel.first] [.e index sel.last]
+} -result {0 10}
+
+test entry-4.7 {sel.first and sel.last gravity} -body {
+    set result [list]
+    .e delete 0 end
+    .e insert 0 0123456789
+    .e select range 2 6
+    .e insert 2 XXX
+    lappend result [.e index sel.first] [.e index sel.last]
+    .e insert 6 YYY
+    lappend result [.e index sel.first] [.e index sel.last] [.e get]
+} -result {5 9 5 12 01XXX2YYY3456789}
+
+# Self-destruct tests.
+
+test entry-5.1 {widget deletion while active} -body {
+    destroy .e
+    pack [ttk::entry .e]
+    update
+    .e config -xscrollcommand { destroy .e }
+    update idletasks
+    winfo exists .e
+} -result 0
+
+# TODO: test killing .e in -validatecommand, -invalidcommand, variable trace;
+
+# -textvariable tests.
+
+test entry-6.1 {Update linked variable in write trace} -body {
+    proc override args {
+	global x
+	set x "Overridden!"
+    }
+    catch {destroy .e}
+    set x ""
+    trace variable x w override
+    ttk::entry .e -textvariable x
+    .e insert 0 "Some text"
+    set result [list $x [.e get]]
+    set result
+} -result {Overridden! Overridden!} -cleanup {
+    unset x
+    rename override {}
+    destroy .e
+}
+
+test entry-6.2 {-textvariable tests} -body {
+    set result [list]
+    ttk::entry .e -textvariable x
+    set x "text"
+    lappend result [.e get]
+    unset x
+    lappend result [.e get]
+    .e insert end "newtext"
+    lappend result [.e get] [set x]
+} -result [list "text" "" "newtext" "newtext"] -cleanup {
+    destroy .e
+    unset -nocomplain x
+}
+
+test entry-7.1 {Bad style options} -body {
+    ttk::style theme create entry-7.1 -settings {
+	ttk::style configure TEntry -foreground BadColor
+	ttk::style map TEntry -foreground {readonly AnotherBadColor}
+	ttk::style map TEntry -font {readonly ABadFont}
+	ttk::style map TEntry \
+	    -selectbackground {{} BadColor} \
+	    -selectforeground {{} BadColor} \
+	    -insertcolor {{} BadColor}
+    }
+    pack [ttk::entry .e -text "Don't crash"]
+    ttk::style theme use entry-7.1
+    update
+    .e selection range 0 end
+    update
+    .e state readonly;
+    update
+} -cleanup { destroy .e ; ttk::style theme use default }
+
+test entry-8.1 "Unset linked variable" -body {
+    variable foo "bar"
+    pack [ttk::entry .e -textvariable foo]
+    unset foo
+    .e insert end "baz"
+    list [.e cget -textvariable] [.e get] [set foo]
+} -result [list foo "baz" "baz"] -cleanup { destroy .e }
+
+test entry-8.2 "Unset linked variable by deleting namespace" -body {
+    namespace eval ::test  { variable foo "bar" }
+    pack [ttk::entry .e -textvariable ::test::foo]
+    namespace delete ::test
+    .e insert end "baz"		;# <== error here
+    list [.e cget -textvariable] [.e get] [set foo]
+} -returnCodes error -result "*parent namespace doesn't exist*" -match glob
+# '-result [list ::test::foo "baz" "baz"]' would also be sensible,
+# but Tcl namespaces don't work that way.
+
+test entry-8.2a "Followup to test 8.2" -body {
+    .e cget -textvariable
+} -result ::test::foo -cleanup { destroy .e }
+# For 8.2a, -result {} would also be sensible.
+
+test entry-9.1 "Index range invariants" -setup {
+    # See bug#1721532 for discussion
+    proc entry-9.1-trace {n1 n2 op} {
+    	set ::V NO!
+    }
+    variable V
+    trace add variable V write entry-9.1-trace
+    ttk::entry .e -textvariable V
+} -body {
+    set result [list]
+    .e insert insert a ; lappend result [.e index insert] [.e index end]
+    .e insert insert b ; lappend result [.e index insert] [.e index end]
+    .e insert insert c ; lappend result [.e index insert] [.e index end]
+    .e insert insert d ; lappend result [.e index insert] [.e index end]
+    .e insert insert e ; lappend result [.e index insert] [.e index end]
+    set result
+} -result [list 1 3  2 3  3 3  3 3  3 3] -cleanup {
+    unset V
+    destroy .e
+}
+
+tcltest::cleanupTests

data/pkgs/tile-0.8.2/tests/entrytest.tcl

@@ -0,0 +1,78 @@
+#
+# Side-by-side comparison of Tile vs. standard entry widgets.
+#
+
+lappend auto_path . ; 
+package require tile
+
+source [file join [file dirname [info script]] testutils.tcl]
+
+style theme use alt
+
+. configure -padx 10 -pady 10
+
+grid [ttk::scrollbar .tsb -orient horizontal -command [list .te xview]] \
+	-pady 2 -sticky news
+grid [ttk::entry .te -textvariable ::A -xscrollcommand [list .tsb set]] \
+	-pady 2 -sticky news
+grid [entry .e -textvariable ::A -xscrollcommand [list .sb set]] \
+	-pady 2 -sticky news
+grid [ttk::scrollbar .sb -orient horizontal -command [list .e xview]] \
+	-pady 2 -sticky news
+
+grid rowconfigure . 1 -weight 1
+grid rowconfigure . 2 -weight 1
+grid columnconfigure . 0 -weight 1
+
+.te insert end "abcde fghij klmn opqr stuv wxyz"
+
+#
+# Test various options.
+#
+proc configboth {args} { 
+    eval .e configure $args
+    eval .te configure $args
+}
+bind all <Alt-Key-d> { configboth -state disabled }	;# "&disable"
+bind all <Alt-Key-e> { configboth -state normal }	;# "&enable"
+bind all <Alt-Key-w> { configboth -state readonly }	;# "&write-protect"
+
+bind all <Alt-Key-l> { configboth -justify left }
+bind all <Alt-Key-r> { configboth -justify right }
+bind all <Alt-Key-c> { configboth -justify center }
+
+bind all <Alt-Key-q> { destroy . }
+
+
+#
+# Validation test.
+#
+# "If you can't see the fnords, they can't eat you."
+#
+proc nofnords {w p} {
+    if {[set i [string first fnord $p]] >= 0} {
+	return 0
+    }
+    if {[set i [string first FNORD $p]] >= 0} {
+	$w delete 0 end; 
+	$w insert end [string replace $p $i [expr {$i+4}]]
+	$w icursor $i
+    }
+    return 1
+}
+
+configboth -validatecommand {nofnords %W %P} -validate all
+
+# Use gaudy colors to highlight selection:
+#
+
+proc gaudyColors {} {
+    .te configure \
+	-insertcolor red -selectbackground blue -selectforeground green
+    .e configure \
+	-insertbackground red -selectbackground blue -selectforeground green \
+	-background white 
+}
+bind all <Alt-KeyPress-g> { gaudyColors }
+
+#*EOF*

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

@@ -0,0 +1,94 @@
+#
+# image.test,v 1.9 2007/11/25 17:06:02 jenglish Exp
+#
+
+package require Tk
+package require tcltest ; namespace import -force tcltest::*
+loadTestedCommands
+
+lappend auto_path .
+package require tile
+
+# catch background errors:
+#
+if {[info procs bgerror] == "bgerror"} { rename bgerror {} }
+array set BGerror { caught 0 message {} }
+proc bgerror {message} {
+    variable BGerror
+    set BGerror(caught) 1
+    set BGerror(message) $message
+}
+proc caughtbgerror {} {
+    variable BGerror
+    if {!$BGerror(caught)} {
+        error "No bgerror caught"
+    }
+    set BGerror(caught) 0
+    return $BGerror(message)
+}
+
+test image-1.1 "Bad image element" -body {
+    ttk::style element create BadImage image badimage
+    #- ttk::style layout BadImage { BadImage }
+    #- ttk::label .l -style BadImage
+    #- pack .l ; update
+    #- destroy .l
+    #- caughtbgerror
+} -returnCodes error -result {image "badimage" doesn't exist}
+
+test image-1.2 "Duplicate element" -setup {
+    image create photo test.element -width 10 -height 10
+    ttk::style element create testElement image test.element
+} -body {
+    ttk::style element create testElement image test.element
+} -returnCodes 1 -result "Duplicate element testElement"
+
+test image-1.3 "Bad image element later in list" -body {
+    ttk::style element create BadImage image {test.element {} badimage}
+} -returnCodes error -result {image "badimage" doesn't exist}
+
+test image-1.4 "Bad image option" -body {
+    ttk::button .b -image [list test.element {} badimage]
+} -returnCodes error -result {image "badimage" doesn't exist}
+
+test image-2.0 "Deletion of displayed image (label)" -constraints {
+    KNOWNBUG
+} -setup {
+    image create photo test.image -width 10 -height 10
+} -body {
+    pack [set w [ttk::label .ttk_image20 -image test.image]]
+    tkwait visibility $w
+    image delete test.image
+    update
+} -cleanup {
+    destroy .ttk_image20
+} -result {}
+    
+test image-2.1 "Deletion of displayed image (checkbutton)" -constraints {
+    KNOWNBUG 
+} -setup {
+    image create photo test.image -width 10 -height 10
+} -body {
+    pack [set w [ttk::checkbutton .ttk_image21 -image test.image]]
+    tkwait visibility $w
+    image delete test.image
+    update
+} -cleanup {
+    destroy .ttk_image21
+} -result {}
+
+test image-2.2 "Deletion of displayed image (radiobutton)" -constraints {
+    KNOWNBUG
+} -setup {
+    image create photo test.image -width 10 -height 10
+} -body {
+    pack [set w [ttk::radiobutton .ttk_image22 -image test.image]]
+    tkwait visibility $w
+    image delete test.image
+    update
+} -cleanup {
+    destroy .ttk_image22
+} -result {}
+
+#
+tcltest::cleanupTests