summaryrefslogtreecommitdiffstats
path: root/tests/ttk/ttk.test
blob: e58b02137b93f74fc16bea0f96d8ef5ff1369368 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647

package require Tk 8.5
package require tcltest ; namespace import -force tcltest::*
loadTestedCommands

proc skip args {}
proc ok {} { return }

variable widgetClasses {
    button checkbutton radiobutton menubutton label entry
    frame labelframe scrollbar
    notebook progressbar combobox separator
    panedwindow treeview sizegrip
    scale
}

proc bgerror {error} {
    variable bgerror $error
    variable bgerrorInfo $::errorInfo
    variable bgerrorCode $::errorCode
}

# Self-destruct tests.
# Do these early, so any memory corruption has a longer time to cause a crash.
#
proc selfdestruct {w args} {
    destroy $w
}
test ttk-6.1 "Self-destructing checkbutton" -body {
    pack [ttk::checkbutton .sd -text "Self-destruction" -variable ::sd]
    trace variable sd w [list selfdestruct .sd]
    update
    .sd invoke
} -returnCodes 1
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 "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]
    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} {
	$class .b1 -textvariable V
	set V "asdf"
	destroy .b1
	set V ""
    }
}

test ttk-6.6 "Bad color spec in styles" -body {
    pack [ttk::button .b1 -text Hi!]
    ttk::style configure TButton -foreground badColor
    event generate .b1 <Expose>
    update
    ttk::style configure TButton -foreground black
    destroy .b1
    set ::bgerror
} -result {unknown color name "badColor"}

test ttk-6.7 "Basic destruction test" -body {
    foreach widget $widgetClasses {
	ttk::$widget .w
	pack .w
	destroy .w
    }
}

test ttk-6.8 "Button command removes itself" -body {
    ttk::button .b -command ".b configure -command {}; set ::A {it worked}"
    .b invoke
    destroy .b
    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}
    }
    ttk::style theme use badfont
} -cleanup {
    ttk::style theme use default
} -body {
    pack [ttk::label .l -text Hi! -font {}]
    event generate .l <Expose>
    update
    destroy .l
    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 {}]

test ttk-selfdestruct-ok-1 "Intentional self-destruction" -body {
    # see #2298720
    toplevel .t
    ttk::button .t.b -command [list destroy .t]
    .t.b invoke
    list [winfo exists .t] [winfo exists .t.b]
} -result [list 0 0]

#
# Basic tests.
#
test ttk-1.1 "Create button" -body {
    pack [ttk::button .t] -expand true -fill both
    update
}

test ttk-1.2 "Check style" -body {
    .t cget -style
} -result {}

test ttk-1.3 "Set bad style" -body {
    .t configure -style "nosuchstyle"
} -returnCodes 1 -result {Layout nosuchstyle not found}

test ttk-1.4 "Original style preserved" -body {
    .t cget -style
} -result ""

proc checkstate {w} {
    foreach statespec {
	{!active !disabled}
	{!active disabled}
	{active !disabled}
	{active disabled}
    	active
	disabled
    } {
    	lappend result [$w instate $statespec]
    }
    set result
}

# NB: this will fail if the top-level window pops up underneath the cursor
test ttk-2.0 "Check state" -body {
    checkstate .t
} -result [list 1 0 0 0 0 0]

test ttk-2.1 "Change state" -body {
    .t state active
} -result !active

test ttk-2.2 "Check state again" -body {
    checkstate .t
} -result [list 0 0 1 0 1 0]

test ttk-2.3 "Change state again" -body {
    .t state {!active disabled}
} -result {active !disabled}

test ttk-2.4 "Check state again" -body {
    checkstate .t
} -result [list 0 1 0 0 0 1]

test ttk-2.5 "Change state again" -body {
    .t state !disabled
} -result {disabled}

test ttk-2.6 "instate scripts, false" -body {
    set x 0
    .t instate disabled { set x 1 }
    set x
} -result 0

test ttk-2.7 "instate scripts, true" -body {
    set x 0
    .t instate !disabled { set x 1 }
    set x
} -result 1

test ttk-2.8 "bug 3223850: button state disabled during click" -setup {
    destroy .b
    set ttk28 {}
    pack [ttk::button .b -command {set ::ttk28 failed}]
} -body { 
    bind .b <ButtonPress-1> {after 0 {.b configure -state disabled}}
    after 1 {event generate .b <ButtonPress-1>}
    after 20 {event generate .b <ButtonRelease-1>}
    set aid [after 100 {set ::ttk28 [.b instate {disabled !pressed}]}]
    vwait ::ttk28
    after cancel $aid
    set ttk28
} -cleanup {
    destroy .b
    unset -nocomplain ttk28 aid
} -result 1

foreach wc $widgetClasses {
    test ttk-coreoptions-$wc "$wc has all core options" -body {
	ttk::$wc .w
	foreach option {-class -style -cursor -takefocus} {
	    .w cget $option
	}
    } -cleanup {
	catch {destroy .w}
    }
}

# misc. error detection
test ttk-3.0 "Bad option" -body {
    ttk::button .bad -badoption foo
} -returnCodes 1 -result {unknown option "-badoption"} -match glob

test ttk-3.1 "Make sure widget command not created" -body {
    .bad state disabled
} -returnCodes 1 -result {invalid command name ".bad"} -match glob

test ttk-3.2 "Propagate errors from variable traces" -body {
    set A 0
    trace add variable A write {error "failure" ;# }
    ttk::checkbutton .cb -variable A
    .cb invoke
} -cleanup {
    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]
    update
} -cleanup {
    ttk::style configure TScale -sliderrelief raised
    destroy .s
}

# Test resource allocation
# (@@@ "-font" is a compatibility option now, so tests 4.1-4.3
# don't really test anything useful at the moment.)
#

test ttk-4.0 "Setup" -body {
    catch { destroy .t }
    pack [ttk::label .t -text "Button 1"]
    testConstraint fontOption [expr ![catch { set prevFont [.t cget -font] }]]
    ok
}

test ttk-4.1 "Change font" -constraints fontOption -body {
    .t configure -font "Helvetica 18 bold"
}
test ttk-4.2 "Check font" -constraints fontOption -body {
    .t cget -font
} -result "Helvetica 18 bold"

test ttk-4.3 "Restore font" -constraints fontOption -body {
    .t configure -font $prevFont
}

test ttk-4.4 "Bad resource specifications" -body {
    ttk::style theme settings alt {
	ttk::style configure TButton -font {Bad font}
	# @@@ it would be best to raise an error at this point,
	# @@@ but that's not really feasible in the current framework.
    }
    pack [ttk::button .tb1 -text "Ouch"]
    ttk::style theme use alt
    update;
    # As long as we haven't crashed, everything's OK
    ttk::style theme settings alt {
    	ttk::style configure TButton -font TkDefaultFont
    }
    ttk::style theme use default
    destroy .tb1
}

#
# -compound tests:
#
variable iconData \
{R0lGODlhIAAgAKIAANnZ2YQAAP8AAISEhP///////////////yH5BAEAAAAALAAAAAAgACAA
AAP/CLoMGLqKoMvtGIqiqxEYCLrcioGiyxwIusyBgaLLLRiBoMsQKLrcjYGgu4Giy+2CAkFX
A0WX2wXFIOgGii7trkCEohsDCACBoktEKLpKhISiGwAIECiqSKooukiqKKoxgACBooukKiIo
SKooujGDECi6iqQqsopEV2MQAkV3kXQZRXdjEAJFl5F0FUWXY3ACRZcFSRdFlyVwJlB0WZB0
UXRZAmcCRZeRdBVFl2NwAkV3kXQZRXdjcAJFV5FURVaR6GoMDgSKLpKqiKAgqaLoxgwOBIoq
kiqKLpIqimrM4ECg6BIRiq4SIaHoxgyCBoou7a5AhKIbMzgAAIGiy+2CTWJmBhAAAkWX2wXF
zCDoBooud2PMDIKuRqDocgtGzMwg6O4Eii5z4Kgi6DIMhqLoagQGjiqCLvPgYOgqji6CLrfi
6DIj6HI7jq4i6DIkADs=}

variable compoundStrings {text image center top bottom left right none}

if {0} {
    proc now {} { set ::now [clock clicks -milliseconds] }
    proc tick {} { puts -nonewline stderr "+" ; flush stderr }
    proc tock {} {
	set then $::now; set ::now [clock clicks -milliseconds]
	puts stderr " [expr {$::now - $then}] ms"
    }
} else {
    proc now {} {} ; proc tick {} {} ; proc tock {} {}
}

now ; tick
test ttk-8.0 "Setup for 8.X" -body {
    ttk::button .ctb
    image create photo icon -data $::iconData;
    pack .ctb
}
tock

now
test ttk-8.1 "Test -compound options" -body {
    # Exhaustively test each combination.
    # Main goal is to make sure no code paths crash.
    foreach image {icon ""} {
        foreach text {"Hi!" ""} {
	    foreach compound $::compoundStrings {
		.ctb configure -image $image -text $text -compound $compound
		update; tick
	    }
	}
    }
}
tock

test ttk-8.2 "Test -compound options with regular button" -body {
    button .rtb
    pack .rtb

    foreach image {"" icon} {
        foreach text {"Hi!" ""} {
	    foreach compound [lrange $::compoundStrings 2 end] {
		.rtb configure -image $image -text $text -compound $compound
		update; tick
	    }
	}
    }
}
tock

test ttk-8.3 "Rerun test 8.1" -body {
    foreach image {icon ""} {
        foreach text {"Hi!" ""} {
	    foreach compound $::compoundStrings {
		.ctb configure -image $image -text $text -compound $compound
		update; tick
	    }
	}
    }
}
tock

test ttk-8.4 "ImageChanged" -body {
    ttk::button .b -image icon
    icon blank
} -cleanup { destroy .b }

#------------------------------------------------------------------------

test ttk-9.1 "Traces on nonexistant namespaces" -body {
    ttk::checkbutton .tcb -variable foo::bar
} -returnCodes 1 -result "*parent namespace doesn't exist*" -match glob

test ttk-9.2 "Traces on nonexistant namespaces II" -body {
    ttk::checkbutton .tcb -variable X
    .tcb configure -variable foo::bar
} -returnCodes 1 -result "*parent namespace doesn't exist*" -match glob

test ttk-9.3 "Restore saved options on configure error" -body {
    .tcb cget -variable
} -result X

test ttk-9.4 "Textvariable tests" -body {
    set tcbLabel "Testing..."
    .tcb configure -textvariable tcbLabel
    .tcb cget -text
} -result "Testing..."

# Changing -text has no effect if there is a linked -textvariable.
# Compatible with core widget.
test ttk-9.5 "Change -text" -body {
    .tcb configure -text "Changed -text"
    .tcb cget -text
} -result "Testing..."

# Unset -textvariable clears the text.
# NOTE: this is different from core widgets, which automagically reinitalize
# the -textvariable to the last value of -text.
#
test ttk-9.6 "Unset -textvariable" -body {
    unset tcbLabel
    list [info exists tcbLabel] [.tcb cget -text]
} -result [list 0 ""]

test ttk-9.7 "Unset textvariable, comparison" -body {
#
# 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
    label .l -text Foo ; ttk::label .tl -text Foo

    .l configure -textvariable V1 ; .tl configure -textvariable V2
    list [set V1] [info exists V2]
} -cleanup { destroy .l .tl } -result [list Foo 0]

test ttk-9.8 "-textvariable overrides -text" -body {
    ttk::label .tl -textvariable TV
    set TV Foo
    .tl configure -text Bar
    .tl cget -text
} -cleanup { destroy .tl } -result "Foo"

#
# Frame widget tests:
#

test ttk-10.1 "ttk::frame -class resource" -body {
    ttk::frame .f -class Foo
} -result .f

test ttk-10.2 "Check widget class" -body {
    winfo class .f
} -result Foo

test ttk-10.3 "Check class resource" -body {
    .f cget -class
} -result Foo

test ttk-10.4 "Try to modify class resource" -body {
    .f configure -class Bar
} -returnCodes 1 -match glob -result "*read-only option*"

test ttk-10.5 "Check class resource again" -body {
    .f cget -class
} -result Foo

test ttk-11.1 "-state test, setup" -body {
    ttk::button .b
    .b instate disabled
} -result 0

test ttk-11.2 "-state test, disable" -body {
    .b configure -state disabled
    .b instate disabled
} -result 1

test ttk-11.3 "-state test, reenable" -body {
    .b configure -state normal
    .b instate disabled
} -result 0

test ttk-11.4 "-state test, unrecognized -state value" -body {
    .b configure -state bogus
    .b state
} -result [list]

test ttk-11.5 "-state test, 'active'" -body {
    .b configure -state active
    .b state
} -result [list active] -cleanup  { .b state !active }

test ttk-11.6 "-state test, 'readonly'" -body {
    .b configure -state readonly
    .b state
} -result [list readonly] -cleanup { .b state !readonly }

test ttk-11.7 "-state test, cleanup" -body {
    destroy .b
}

test ttk-12.1 "-cursor option" -body {
    ttk::button .b
    .b cget -cursor
} -result {}

test ttk-12.2 "-cursor option" -body {
    .b configure -cursor arrow
    .b cget -cursor
} -result arrow

test ttk-12.3 "-borderwidth frame option" -body {
    destroy .t
    toplevel .t
    raise .t
    pack [set t [ttk::frame .t.f]] -expand true -fill x ;
    pack [ttk::label $t.l -text "ASDF QWERTY"] -expand true -fill both
    foreach theme {default alt} {
	ttk::style theme use $theme
	foreach relief {flat raised sunken ridge groove solid} {
	    $t configure -relief $relief
	    for {set i 5} {$i >= 0} {incr i -1} {
		$t configure -borderwidth $i
		update
	    }
	}
    }
}

test ttk-12.4 "-borderwidth frame option" -body {
    .t.f configure -relief raised
    .t.f configure -borderwidth 1
    ttk::style theme use alt
    update
}

test ttk-13.1 "Custom styles -- bad -style option" -body {
    ttk::button .tb1 -style badstyle
} -returnCodes 1 -result "*badstyle not found*" -match glob

test ttk-13.4 "Custom styles -- bad -style option" -body {
    ttk::button .tb1
    .tb1 configure -style badstyle
} -cleanup {
    destroy .tb1
} -returnCodes 1 -result "*badstyle not found*" -match glob

test ttk-13.5 "Custom layouts -- missing element definition" -body {
    ttk::style layout badstyle {
    	NoSuchElement
    }
    ttk::button .tb1 -style badstyle
} -cleanup {
    destroy .tb1
} -result .tb1
# @@@ Should: signal an error, possibly a background error.

#
# See #793909
#

test ttk-14.1 "-variable in nonexistant namespace" -body {
    ttk::checkbutton .tw -variable ::nsn::foo
} -returnCodes 1 -result {can't trace *: parent namespace doesn't exist} \
  -match glob -cleanup { destroy .tw }

test ttk-14.2 "-textvariable in nonexistant namespace" -body {
    ttk::label .tw -textvariable ::nsn::foo
} -returnCodes 1 -result {can't trace *: parent namespace doesn't exist} \
  -match glob -cleanup { destroy .tw }

test ttk-14.3 "-textvariable in nonexistant namespace" -body {
    ttk::entry .tw -textvariable ::nsn::foo
} -returnCodes 1 -result {can't trace *: parent namespace doesn't exist} \
  -match glob -cleanup { destroy .tw }

test ttk-15.1 {Bug 3062331} -setup {
    destroy .b
} -body {
    set Y {}
    ttk::button .b -textvariable Y
    trace variable Y u "destroy .b; #"
    unset Y
} -cleanup {
    destroy .b
} -result {}

test ttk-15.2 {Bug 3341056} -setup {
    proc foo {} {
	destroy .lf
	ttk::labelframe .lf
	ttk::checkbutton .lf.cb -text xxx
    }
} -body {
    ttk::button .b -text xxx -command foo
    .b invoke
    .b invoke
    .lf.cb invoke
    destroy .b
} -cleanup {
    rename foo {}
    destroy .lf
} -result {}

## Test ensemble processing:
#
# (See also: SF#2021443)
#
proc wrong#args {args} {
    return "wrong # args: should be \"$args\""
}
proc wrong#varargs {varpart args} {
    set usage $args
    append usage " ?$varpart ...?"
    return "wrong # args: should be \"$usage\""
}

test ttk-ensemble-0 "style element create: insufficient args" -body {
     ttk::style
} -returnCodes 1 -result \
    [wrong#varargs arg ttk::style option]

test ttk-ensemble-1 "style element create: insufficient args" -body {
     ttk::style element
} -returnCodes 1 -result \
    [wrong#varargs arg ttk::style element option]

test ttk-ensemble-2 "style element create: insufficient args" -body {
     ttk::style element create
} -returnCodes 1 -result \
    [wrong#varargs {-option value} ttk::style element create name type]

test ttk-ensemble-3 "style element create: insufficient args" -body {
     ttk::style element create plain.background
} -returnCodes 1 -result \
    [wrong#varargs {-option value} ttk::style element create name type]

test ttk-ensemble-4 "style element create: insufficient args" -body {
     ttk::style element create plain.background from
} -returnCodes 1 -result [wrong#args theme ?element?]

test ttk-ensemble-5 "style element create: valid" -body {
     ttk::style element create plain.background from default
} -returnCodes 0 -result ""

eval destroy [winfo children .]

tcltest::cleanupTests

#*EOF*