1 #---------------------------------------------------------------------
6 # Arnulf Wiedemann with a lot of code form the snit tests by
10 # Test cases for ::itcl::type command.
11 # Uses the ::tcltest:: harness.
13 # There is at least Tcl 8.6a3 needed
15 # The tests assume tcltest 2.2
16 #-----------------------------------------------------------------------
18 # ### ### ### ######### ######### #########
19 ## Declare the minimal version of Tcl required to run the package
20 ## tested by this testsuite, and its dependencies.
22 proc testsNeedTcl {version} {
23 # This command ensures that a minimum version of Tcl is used to
24 # run the tests in the calling testsuite. If the minimum is not
25 # met by the active interpreter we forcibly bail out of the
26 # testsuite calling the command. The command has to be called
27 # immediately after loading the utilities.
29 if {[package vsatisfies [package provide Tcl] ${version}-]} return
31 puts " Aborting the tests found in \"[file tail [info script]]\""
32 puts " Requiring at least Tcl $version, have [package provide Tcl]."
34 # This causes a 'return' in the calling scope.
38 # ### ### ### ######### ######### #########
39 ## Declare the minimum version of Tcltest required to run the
42 proc testsNeedTcltest {version} {
43 # This command ensure that a minimum version of the Tcltest
44 # support package is used to run the tests in the calling
45 # testsuite. If the minimum is not met by the loaded package we
46 # forcibly bail out of the testsuite calling the command. The
47 # command has to be called after loading the utilities. The only
48 # command allowed to come before it is 'textNeedTcl' above.
50 # Note that this command will try to load a suitable version of
51 # Tcltest if the package has not been loaded yet.
53 if {[lsearch [namespace children] ::tcltest] == -1} {
55 package require tcltest $version
57 namespace import -force ::tcltest::*
60 } elseif {[package vcompare [package present tcltest] $version] >= 0} {
61 namespace import -force ::tcltest::*
65 puts " Aborting the tests found in [file tail [info script]]."
66 puts " Requiring at least tcltest $version, have [package present tcltest]"
68 # This causes a 'return' in the calling scope.
72 # Set up for Tk tests: enter the event loop long enough to catch
74 proc tkbide {{msg "tkbide"} {msec 500}} {
77 set ::bideErrorInfo ""
78 # It looks like update idletasks does the job.
80 after $msec {set ::bideVar 1}
81 tkwait variable ::bideVar
84 if {"" != $::bideError} {
85 error "$msg: $::bideError" $::bideErrorInfo
94 interp alias {} type {} ::itcl::type
95 interp alias {} widget {} ::itcl::widget
97 # Marks tests which are only for Tk.
98 tcltest::testConstraint tk [expr {![catch {package require Tk}]}]
100 ::tcltest::loadTestedCommands
103 #-----------------------------------------------------------------------
106 # A widget is just a widgetadaptor with an automatically created hull
107 # component (a Tk frame). So the widgetadaptor tests apply; all we
108 # need to test here is the frame creation.
110 test widget-1.1 {creating a widget
115 delegate method * to itcl_hull
116 delegate option * to itcl_hull
119 myframe create .frm -background green
121 set a [.frm cget -background]
122 set b [.frm itcl_hull]
129 } -result {green ::itcl::internal::widgets::hull1.frm}
131 test widget-2.1 {can't redefine hull
135 # there is no need to define or set itcl_hull as that is done automatically
137 method resethull {} {
149 } -result {can't set "itcl_hull": The itcl_hull component cannot be redefined}
152 #-----------------------------------------------------------------------
155 # The install command is used to install widget components, while getting
156 # options for the option database.
158 test install-1.1 {installed components are created properly
163 # Delegate an option just to make sure the component variable
165 delegate option -font to text
168 installcomponent text using text $win.text -background green
172 $win.text cget -background
185 test install-1.2 {installed components are saved properly
190 # Delegate an option just to make sure the component variable
192 delegate option -font to text
195 installcomponent text using text $win.text -background green
199 $text cget -background
212 test install-1.4 {install queries option database
217 delegate option -font to text
220 option add *Myframe.font Courier
224 installcomponent text using text $win.text
229 set a [.frm cget -font]
237 test install-1.5 {explicit options override option database
242 delegate option -font to text
245 option add *Myframe.font Courier
249 installcomponent text using text $win.text -font Times
254 set a [.frm cget -font]
262 test install-1.6 {option db works with targetted options
267 delegate option -textfont to text as -font
270 option add *Myframe.textfont Courier
274 installcomponent text using text $win.text
279 set a [.frm cget -textfont]
287 test install-1.8 {install can install non-widget components
292 option -tailcolor black
296 delegate option -tailcolor to thedog
299 option add *Myframe.tailcolor green
303 installcomponent thedog using dog $win.dog
308 set a [.frm cget -tailcolor]
318 test install-1.9 {ok if no options are delegated to component
323 option -tailcolor black
328 installcomponent thedog using dog $win.dog
336 # Test passes if no error is raised.
344 delegate option * for a non-shadowed option. The text widget's
345 -foreground and -font options should be set according to what's
346 in the option database on the widgetclass.
351 delegate option * to text
354 option add *Myframe.foreground red
355 option add *Myframe.font {Times 14}
359 installcomponent text using text $win.text
364 set a [.frm cget -foreground]
365 set b [.frm cget -font]
372 } -result {red {Times 14}}
376 Delegate option * for a shadowed option. Foreground is declared
377 as a non-delegated option, hence it will pick up the option database
378 default. -foreground is not included in the "delegate option *", so
379 the text widget's -foreground option will not be set from the
385 option -foreground white
386 delegate option * to text
389 option add *Myframe.foreground red
393 installcomponent text using text $win.text
397 $text cget -foreground
402 set a [.frm cget -foreground]
407 expr {![string equal $a $b]}
413 Delegate option * for a creation option. Because the text widget's
414 -foreground is set explicitly by the constructor, that always
415 overrides the option database.
420 delegate option * to text
423 option add *Myframe.foreground red
427 installcomponent text using text $win.text -foreground blue
432 set a [.frm cget -foreground]
442 Delegate option * with an excepted option. Because the text widget's
443 -state is excepted, it won't be set from the option database.
448 delegate option * to text except -state
451 option add *Myframe.foreground red
452 option add *Myframe.state disabled
456 installcomponent text using text $win.text
465 set a [.frm getstate]
475 #-----------------------------------------------------------------------
476 # Advanced installhull tests
478 # installhull is used to install the hull widget for both widgets and
479 # widget adaptors. It has two forms. In one form it installs a widget
480 # created by some third party; in this form no querying of the option
481 # database is needed, because we haven't taken responsibility for creating
482 # it. But in the other form (installhull using) installhull actually
483 # creates the widget, and takes responsibility for querying the
484 # option database as needed.
486 # NOTE: "installhull using" is always used to create a widget's hull frame.
488 # That options passed into installhull override those from the
491 test installhull-1.1 {
492 options delegated to a widget's itcl_hull frame with the same name are
493 initialized from the option database. Note that there's no
494 explicit code in Snit to do this; it happens because we set the
495 -class when the widget was created. In fact, it happens whether
496 we delegate the option name or not.
501 delegate option -background to itcl_hull
504 option add *Myframe.background red
505 option add *Myframe.width 123
509 $itcl_hull cget -width
514 set a [.frm cget -background]
523 test installhull-1.2 {
524 Options delegated to a widget's itcl_hull frame with a different name are
525 initialized from the option database.
530 delegate option -mainbackground to itcl_hull as -background
533 option add *Myframe.mainbackground green
538 set a [.frm cget -mainbackground]
548 test option-5.1 {local widget options read from option database
557 option add *Dog.bar bb
562 set a [.fido cget -foo]
563 set b [.fido cget -bar]
573 test option-5.2 {local option database values available in constructor
582 option add *Dog.bar bb
586 set saveit $itcl_options(-bar)
595 set result [.fido getit]
604 #-----------------------------------------------------------------------
605 # Setting the widget class explicitly
607 test widgetclass-1.3 {widgetclass must begin with uppercase letter
616 } -result {widgetclass "dog" does not begin with an uppercase letter}
618 test widgetclass-1.4 {widgetclass can only be defined once
628 } -result {too many widgetclass statements}
630 test widgetclass-1.5 {widgetclass set successfully
635 widgetclass DogWidget
638 # The test passes if no error is thrown.
644 test widgetclass-1.6 {implicit widgetclass applied to hull
650 option add *Dog.background green
653 method background {} {
654 $itcl_hull cget -background
660 set bg [.dog background]
669 test widgetclass-1.7 {explicit widgetclass applied to hull
674 widgetclass DogWidget
677 option add *DogWidget.background yellow
680 method background {} {
681 $itcl_hull cget -background
687 set bg [.dog background]
696 #-----------------------------------------------------------------------
699 test hulltype-1.3 {hulltype can be frame
704 delegate option * to itcl_hull
709 catch {.fido configure -use} result
716 } -result {unknown option "-use"}
718 test hulltype-1.4 {hulltype can be toplevel
723 delegate option * to itcl_hull
728 catch {.fido configure -use} result
735 } -result {-use use Use {} {}}
737 test hulltype-1.5 {hulltype can only be defined once
747 } -result {too many hulltype statements}
749 test hulltype-2.1 {list of valid hulltypes
756 lsort [dog info hulltypes]
759 } -result {frame labelframe toplevel ttk:frame ttk:labelframe ttk:toplevel}
761 test winfo-10.1 {widget info widgets
771 lsort [dog info widgets]
777 test winfo-10.2 {widget info components
791 set a [lsort [dog info components]]
792 set b [lsort [cat info components]]
797 } -result {{comp1 comp2 itcl_hull} {comp1 comp1a itcl_hull}}
799 test winfo-10.3 {widget info widgetclasses
804 widgetclass DogWidget
808 widgetclass CatWidget
811 lsort [dog info widgetclasses]
815 } -result {CatWidget DogWidget}
818 #---------------------------------------------------------------------
821 ::tcltest::cleanupTests