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
|
#
# Public variables as configuration options
# ----------------------------------------------------------------------
# AUTHOR: Michael J. McLennan
# Bell Labs Innovations for Lucent Technologies
# mmclennan@lucent.com
# http://www.tcltk.com/itcl
#
# RCS: $Id: public.test,v 1.3 2004/09/22 09:37:09 davygrvy 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.
package require tcltest
namespace import -force ::tcltest::*
::tcltest::loadTestedCommands
# ----------------------------------------------------------------------
# Define a base class with public variables and a simple mega-widget
# ----------------------------------------------------------------------
test public-1.1 {define base class and simple mega-widget class} {
itcl::class test_public_base {
public variable null
public variable background "not used"
public variable message
}
itcl::configbody test_public_base::message {
global ::test_public_status
lappend test_public_status "message: $message"
}
itcl::configbody test_public_base::background {
global ::test_public_status
lappend test_public_status "background: $background"
}
option add *TestPublic.background red
option add *TestPublic.foreground white
option add *TestPublic.cursor trek
option add *TestPublic.message "Hello, World!"
itcl::class TestPublic {
inherit itk::Widget test_public_base
constructor {args} {
itk_component add mesg {
label $itk_interior.mesg
} {
keep -background -foreground -cursor
rename -text -message message Message
}
pack $itk_component(mesg) -side left -padx 2
eval itk_initialize $args
}
}
set testobj [TestPublic .#auto]
pack $testobj
} {}
test public-1.2 {check the list of configuration options} {
$testobj configure
} {{-background background Background red red} {-clientdata clientData ClientData {} {}} {-cursor cursor Cursor trek trek} {-foreground foreground Foreground white white} {-message message Message {Hello, World!} {Hello, World!}} {-null {} {} {} {}}}
test public-1.3 {uninitialized public variables are set to ""} {
$testobj info variable null
} {public variable ::test_public_base::null <undefined> {} {}}
test public-1.4 {config code gets fired off} {
set test_public_status ""
$testobj configure -background blue -message "All Clear"
set test_public_status
} {{background: blue} {message: All Clear}}
# ----------------------------------------------------------------------
# Clean up
# ----------------------------------------------------------------------
itcl::delete class TestPublic test_public_base
::tcltest::cleanupTests
exit
|
