1 files changed, 38 insertions, 18 deletions

diff --git a/tests/ttk/ttk.test b/tests/ttk/ttk.test
index 4092c40..e050e2a 100644
--- a/tests/ttk/ttk.test
+++ b/tests/ttk/ttk.test
@@ -23,24 +23,24 @@ test ttk-6.1 "Self-destructing checkbutton" -body {
     trace variable sd w [list selfdestruct .sd]
     update
     .sd invoke
-} -returnCodes 1
+} -returnCodes 1 -result "Widget has been destroyed"
 test ttk-6.2 "Checkbutton self-destructed" -body {
     winfo exists .sd
 } -result 0
 
 # test ttk-6.3 not applicable [see #2175411]
 
-test ttk-6.4 "Defeat evil intentions" -body {
+test ttk-6.4 "Destroy widget in configure" -setup {
+    set OUCH ouch
     trace variable OUCH r { kill.b }
     proc kill.b {args} { destroy .b }
+} -cleanup {
+    unset OUCH
+} -body {
     pack [ttk::checkbutton .b]
-    .b configure -variable OUCH
-    # At this point, .b should be gone.
-    .b invoke
-    list [set OUCH] [winfo exists .b]
-    # Mostly we just care that we haven't crashed the interpreter.
-    #
-} -returnCodes error -match glob -result "*"
+    set rc [catch { .b configure -variable OUCH } msg]
+    list $rc $msg [winfo exists .b] [info commands .b]
+} -result [list 1 "Widget has been destroyed" 0 {}]
 
 test ttk-6.5 "Clean up -textvariable traces" -body {
     foreach class {ttk::button ttk::checkbutton ttk::radiobutton} {
@@ -61,7 +61,6 @@ test ttk-6.6 "Bad color spec in styles" -body {
     set ::bgerror
 } -result {unknown color name "badColor"}
 
-# This should move to be a standard test per widget test file
 test ttk-6.7 "Basic destruction test" -body {
     foreach widget {
 	button checkbutton radiobutton sizegrip separator notebook
@@ -80,9 +79,6 @@ test ttk-6.8 "Button command removes itself" -body {
     set ::A
 } -result {it worked}
 
-#
-#
-
 test ttk-6.9 "Bad font spec in styles" -setup {
     ttk::style theme create badfont -settings {
     	ttk::style configure . -font {Helvetica 12 Bogus}
@@ -98,6 +94,30 @@ test ttk-6.9 "Bad font spec in styles" -setup {
     set ::bgerror
 } -result {unknown font style "Bogus"}
 
+test ttk-construction-failure-1 "Excercise construction failure path" -setup {
+    option add *TLabel.cursor badCursor 1
+} -cleanup {
+    option add *TLabel.cursor {} 1
+} -body {
+    catch {ttk::label .l} errmsg
+    list $errmsg [info commands .l] [winfo exists .l]
+} -result [list {bad cursor spec "badCursor"} {} 0]
+
+test ttk-construction-failure-2 "Destroy widget in constructor" -setup {
+    set OUCH ouch
+    trace variable OUCH r { kill.b }
+    proc kill.b {args} { destroy .b }
+} -cleanup {
+    unset OUCH
+} -body {
+    list \
+	[catch { ttk::checkbutton .b -variable OUCH } msg] \
+	$msg \
+    	[winfo exists .b] \
+	[info commands .b] \
+	;
+} -result [list 1 "Widget has been destroyed" 0 {}]
+
 #
 # Basic tests.
 #
@@ -111,7 +131,6 @@ test ttk-1.2 "Check style" -body {
     .t cget -style
 } -result {}
 
-
 test ttk-1.4 "Restore default style" -body {
     .t cget -style
 } -result ""
@@ -167,7 +186,6 @@ test ttk-2.7 "instate scripts, true" -body {
     set x
 } -result 1
 
-
 # misc. error detection
 test ttk-3.0 "Bad option" -body {
     ttk::button .bad -badoption foo
@@ -186,6 +204,10 @@ test ttk-3.2 "Propagate errors from variable traces" -body {
     unset ::A ; destroy .cb
 } -returnCodes error -result {can't set "A": failure}
 
+test ttk-3.3 "Constructor failure with cursor" -body {
+    ttk::button .b -cursor bottom_right_corner -style BadStyle
+} -returnCodes 1 -result "Layout BadStyle not found"
+
 test ttk-3.4 "SF#2009213" -body {
     ttk::style configure TScale -sliderrelief {}
     pack [ttk::scale .s]
@@ -439,7 +461,7 @@ test ttk-9.6 "Unset -textvariable" -body {
 
 test ttk-9.7 "Unset textvariable, comparison" -body {
 #
-# NB: the ttk label behaves differently from the standard label here;
+# NB: ttk::label behaves differently from the standard label here;
 # NB: this is on purpose: I believe the standard behaviour is the Wrong Thing
 #
     unset -nocomplain V1  V2
@@ -549,7 +571,6 @@ test ttk-12.4 "-borderwidth frame option" -body {
     update
 }
 
-
 test ttk-13.1 "Custom styles -- bad -style option" -body {
     ttk::button .tb1 -style badstyle
 } -returnCodes 1 -result "*badstyle not found*" -match glob
@@ -590,7 +611,6 @@ test ttk-14.3 "-textvariable in nonexistant namespace" -body {
 } -returnCodes 1 -result {can't trace *: parent namespace doesn't exist} \
   -match glob -cleanup { destroy .tw }
 
-
 test ttk-15.1 "style element create: insufficient args" -body {
      ttk::style element create
 } -returnCodes 1 -result "wrong # args: should be \"ttk::style element create name type ?-option value ...?\""