OpenCores
URL https://opencores.org/ocsvn/or1k/or1k/trunk

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [itcl/] [itk/] [tests/] [widget.test] - Blame information for rev 1780

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 578 markom 
#
2 
# Tests for [incr Tk] widgets based on itk::Widget
3 
# ----------------------------------------------------------------------
4 
#   AUTHOR:  Michael J. McLennan
5 
#            Bell Labs Innovations for Lucent Technologies
6 
#            mmclennan@lucent.com
7 
#            http://www.tcltk.com/itcl
8 
#
9 
#      RCS:  $Id: widget.test,v 1.1.1.1 2002-01-16 10:24:48 markom Exp $
10 
# ----------------------------------------------------------------------
11 
#            Copyright (c) 1993-1998  Lucent Technologies, Inc.
12 
# ======================================================================
13 
# See the file "license.terms" for information on usage and
14 
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
15 
 
16 
if {[string compare test [info procs test]] == 1} then {source defs}
17 
 
18 
# ----------------------------------------------------------------------
19 
#  Simple mega-widget
20 
# ----------------------------------------------------------------------
21 
test widget-1.1 {define a simple mega-widget class} {
22 
    option add *TestWidget.background linen
23 
    option add *TestWidget.borderWidth 2
24 
    option add *TestWidget.command ""
25 
    option add *TestWidget.cursor ""
26 
    option add *TestWidget.foreground navy
27 
    option add *TestWidget.highlight white
28 
    option add *TestWidget.normal ivory
29 
    option add *TestWidget.text ""
30 
 
31 
    itcl::class TestWidget {
32 
        inherit itk::Widget
33 
        constructor {args} {
34 
            itk_component add test1 {
35 
                label $itk_interior.t1
36 
            } {
37 
                keep -background -foreground -cursor
38 
                keep -text
39 
            }
40 
            pack $itk_component(test1) -side left -padx 2
41 
 
42 
            itk_component add test2 {
43 
                button $itk_interior.t2 -text "Push Me"
44 
            } {
45 
                keep -foreground -cursor -borderwidth -command
46 
                rename -background -normal normal Background
47 
                rename -activebackground -highlight highlight Foreground
48 
            }
49 
            pack $itk_component(test2) -side right -fill x -pady 2
50 
 
51 
            eval itk_initialize $args
52 
        }
53 
        private variable status ""
54 
        public method action {info} {
55 
            lappend status $info
56 
        }
57 
 
58 
        public method do {cmd} {
59 
            eval $cmd
60 
        }
61 
 
62 
        itk_option define -status status Status {} {
63 
            lappend status $itk_option(-status)
64 
        }
65 
    }
66 
    TestWidget .#auto
67 
} {.testWidget0}
68 
 
69 
pack .testWidget0
70 
 
71 
test widget-1.2 {check the list of configuration options} {
72 
    .testWidget0 configure
73 
} {{-background background Background linen linen} {-borderwidth borderWidth BorderWidth 2 2} {-clientdata clientData ClientData {} {}} {-command command Command {} {}} {-cursor cursor Cursor {} {}} {-foreground foreground Foreground navy navy} {-highlight highlight Foreground white white} {-normal normal Background ivory ivory} {-status status Status {} {}} {-text text Text {} {}}}
74 
 
75 
set unique 0
76 
foreach test {
77 
    {-background  {-background background Background linen linen}}
78 
    {-borderwidth {-borderwidth borderWidth BorderWidth 2 2}}
79 
    {-clientdata  {-clientdata clientData ClientData {} {}}}
80 
    {-command     {-command command Command {} {}}}
81 
    {-cursor      {-cursor cursor Cursor {} {}}}
82 
    {-foreground  {-foreground foreground Foreground navy navy}}
83 
    {-highlight   {-highlight highlight Foreground white white}}
84 
    {-normal      {-normal normal Background ivory ivory}}
85 
    {-status      {-status status Status {} {}}}
86 
    {-text        {-text text Text {} {}}}
87 
} {
88 
    set opt [lindex $test 0]
89 
    set result [lindex $test 1]
90 
 
91 
    test widget-1.3.[incr unique] {check individual configuration options} {
92 
        .testWidget0 configure $opt
93 
    } $result
94 
}
95 
 
96 
set unique 0
97 
foreach test {
98 
    {-background  red}
99 
    {-borderwidth 1}
100 
    {-clientdata  "foo bar"}
101 
    {-command     {puts "hello!"}}
102 
    {-cursor      trek}
103 
    {-foreground  IndianRed}
104 
    {-highlight   MistyRose}
105 
    {-normal      MistyRose2}
106 
    {-status      "test message"}
107 
    {-text        "Label:"}
108 
} {
109 
    set opt [lindex $test 0]
110 
    set value [lindex $test 1]
111 
 
112 
    test widget-1.4.[incr unique] {set individual configuration options} {
113 
        list [.testWidget0 configure $opt $value] \
114 
             [.testWidget0 cget $opt] \
115 
             [.testWidget0 do "set itk_option($opt)"]
116 
    } [list "" $value $value]
117 
}
118 
 
119 
test widget-1.5 {check the list components} {
120 
    lsort [.testWidget0 component]
121 
} {hull test1 test2}
122 
 
123 
set unique 0
124 
foreach test {
125 
    {hull  .testWidget0}
126 
    {test1 .testWidget0.t1}
127 
    {test2 .testWidget0.t2}
128 
} {
129 
    set name [lindex $test 0]
130 
    set win  [lindex $test 1]
131 
 
132 
    test widget-1.6 {check the window for each component} {
133 
        list [.testWidget0 component $name] \
134 
             [.testWidget0 do "set itk_component($name)"]
135 
    } [list $win $win]
136 
}
137 
 
138 
test widget-1.7 {check the propagation of configuration options} {
139 
    list [.testWidget0 component hull cget -cursor] \
140 
         [.testWidget0 component test1 cget -cursor] \
141 
         [.testWidget0 component test2 cget -cursor]
142 
} {trek trek trek}
143 
 
144 
test widget-1.8 {check the propagation of configuration options} {
145 
    list [.testWidget0 component hull cget -background] \
146 
         [.testWidget0 component test1 cget -background] \
147 
         [.testWidget0 component test2 cget -background]
148 
} {red red MistyRose2}
149 
 
150 
test widget-1.9 {check the propagation of configuration options} {
151 
    list [.testWidget0 component test1 cget -text] \
152 
         [.testWidget0 component test2 cget -text]
153 
} {Label: {Push Me}}
154 
 
155 
test widget-1.10 {check the invocation of "config" code} {
156 
    .testWidget0 do {set status}
157 
} {{} {test message}}
158 
 
159 
test widget-1.11a {configure using the "code" command} {
160 
    .testWidget0 do {configure -command [code $this action "button press"]}
161 
    .testWidget0 cget -command
162 
} {namespace inscope ::TestWidget {::.testWidget0 action {button press}}}
163 
 
164 
test widget-1.11b {execute some code created by "code" command} {
165 
    .testWidget0 do {set status ""}
166 
    .testWidget0 component test2 invoke
167 
    .testWidget0 configure -status "in between"
168 
    .testWidget0 component test2 invoke
169 
    .testWidget0 do {set status}
170 
} {{button press} {in between} {button press}}
171 
 
172 
test widget-1.12a {components can be added on the fly} {
173 
    .testWidget0 do {
174 
        itk_component add test3 {
175 
            label $itk_interior.t3 -text "Temporary"
176 
        } {
177 
            keep -background -foreground -cursor
178 
        }
179 
    }
180 
} {test3}
181 
 
182 
test widget-1.12b {components can be added on the fly} {
183 
    .testWidget0 do {
184 
        pack $itk_component(test3) -fill x
185 
    }
186 
} {}
187 
 
188 
test widget-1.13 {new components show up on the component list} {
189 
    lsort [.testWidget0 component]
190 
} {hull test1 test2 test3}
191 
 
192 
test widget-1.14 {new components are initialized properly} {
193 
    list [.testWidget0 component test3 cget -background] \
194 
         [.testWidget0 component test3 cget -foreground] \
195 
         [.testWidget0 component test3 cget -cursor]
196 
} {red IndianRed trek}
197 
 
198 
test widget-1.15 {components can be deleted like ordinary widgets} {
199 
    destroy [.testWidget0 component test3]
200 
} {}
201 
 
202 
test widget-1.16 {dead components are removed from the component list} {
203 
    lsort [.testWidget0 component]
204 
} {hull test1 test2}
205 
 
206 
test widget-1.17 {use "configbody" command to change "config" code} {
207 
    configbody TestWidget::status {lappend status "new"}
208 
} {}
209 
 
210 
test widget-1.18 {"config" code can really change} {
211 
    .testWidget0 do {set status ""}
212 
    .testWidget0 configure -status "test message"
213 
    .testWidget0 configure -status "another"
214 
    .testWidget0 do {set status}
215 
} {new new}
216 
 
217 
test widget-1.19 {"config" code can change back} {
218 
    configbody TestWidget::status {lappend status $itk_option(-status)}
219 
} {}
220 
 
221 
test widget-1.20 {mega-widgets show up on the object list} {
222 
    itcl::find objects .testWidget*
223 
} {.testWidget0}
224 
 
225 
test widget-1.21 {when a mega-widget is destroyed, its object is deleted} {
226 
    destroy .testWidget0
227 
    itcl::find objects .testWidget*
228 
} {}
229 
 
230 
test widget-1.22 {recreate a test widget} {
231 
    TestWidget .testWidget0
232 
    itcl::find objects .testWidget*
233 
} {.testWidget0}
234 
 
235 
test widget-1.23 {when an object is deleted the widget is destroyed} {
236 
    itcl::delete object .testWidget0
237 
    winfo exists .testWidget0
238 
} {0}
239 
 
240 
# ----------------------------------------------------------------------
241 
#  Clean up
242 
# ----------------------------------------------------------------------
243 
itcl::delete class TestWidget

powered by: WebSVN 2.1.0

© copyright 1999-2025 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.