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
|
#
# Tests for [incr Tk] widgets based on itk::Toplevel
# ----------------------------------------------------------------------
# AUTHOR: Michael J. McLennan
# Bell Labs Innovations for Lucent Technologies
# mmclennan@lucent.com
# http://www.tcltk.com/itcl
#
# RCS: $Id: toplevel.test,v 1.1 1998/07/27 18:45:33 stanton Exp $
# ----------------------------------------------------------------------
# Copyright (c) 1993-1998 Lucent Technologies, Inc.
# ======================================================================
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[string compare test [info procs test]] == 1} then {source defs}
# ----------------------------------------------------------------------
# Toplevel mega-widget
# ----------------------------------------------------------------------
test toplevel-1.1 {define a toplevel mega-widget class} {
option add *TestToplevel.background linen
option add *TestToplevel.cursor ""
option add *TestToplevel.foreground navy
option add *TestToplevel.highlight white
option add *TestToplevel.normal ivory
option add *TestToplevel.text ""
itcl::class TestToplevel {
inherit itk::Toplevel
constructor {args} {
itk_component add test1 {
label $itk_interior.t1
} {
keep -background -foreground -cursor
keep -text
}
pack $itk_component(test1) -side left -padx 2
eval itk_initialize $args
}
public method do {cmd} {
eval $cmd
}
private variable status ""
itk_option define -background background Background {} {
lappend status "background: $itk_option(-background)"
}
}
TestToplevel .#auto
} {.testToplevel0}
test toplevel-1.2 {check the list of configuration options} {
.testToplevel0 configure
} {{-background background Background linen linen} {-clientdata clientData ClientData {} {}} {-cursor cursor Cursor {} {}} {-foreground foreground Foreground navy navy} {-takefocus takeFocus TakeFocus 0 0} {-text text Text {} {}} {-title title Title {} {}}}
test toplevel-1.3 {check the list components} {
lsort [.testToplevel0 component]
} {hull test1}
test toplevel-1.4 {check the propagation of configuration options} {
.testToplevel0 configure -background red
list [.testToplevel0 component hull cget -background] \
[.testToplevel0 component test1 cget -background] \
[.testToplevel0 do {set status}]
} {red red {{background: linen} {background: red}}}
test toplevel-1.5 {mega-widgets show up on the object list} {
itcl::find objects .testToplevel*
} {.testToplevel0}
test toplevel-1.6 {when a mega-widget is destroyed, its object is deleted} {
destroy .testToplevel0
itcl::find objects .testToplevel*
} {}
# ----------------------------------------------------------------------
# Clean up
# ----------------------------------------------------------------------
itcl::delete class TestToplevel
|
