OpenFPGA/libs/EXTERNAL/tcl8.6.12/pkgs/itcl4.2.2/tests/widgetclass.test

823 lines
18 KiB
Plaintext

#---------------------------------------------------------------------
# TITLE:
# widgetclass.test
#
# AUTHOR:
# Arnulf Wiedemann with a lot of code form the snit tests by
# Will Duquette
#
# DESCRIPTION:
# Test cases for ::itcl::type command.
# Uses the ::tcltest:: harness.
#
# There is at least Tcl 8.6a3 needed
#
# The tests assume tcltest 2.2
#-----------------------------------------------------------------------
# ### ### ### ######### ######### #########
## Declare the minimal version of Tcl required to run the package
## tested by this testsuite, and its dependencies.
proc testsNeedTcl {version} {
# This command ensures that a minimum version of Tcl is used to
# run the tests in the calling testsuite. If the minimum is not
# met by the active interpreter we forcibly bail out of the
# testsuite calling the command. The command has to be called
# immediately after loading the utilities.
if {[package vsatisfies [package provide Tcl] ${version}-]} return
puts " Aborting the tests found in \"[file tail [info script]]\""
puts " Requiring at least Tcl $version, have [package provide Tcl]."
# This causes a 'return' in the calling scope.
return -code return
}
# ### ### ### ######### ######### #########
## Declare the minimum version of Tcltest required to run the
## testsuite.
proc testsNeedTcltest {version} {
# This command ensure that a minimum version of the Tcltest
# support package is used to run the tests in the calling
# testsuite. If the minimum is not met by the loaded package we
# forcibly bail out of the testsuite calling the command. The
# command has to be called after loading the utilities. The only
# command allowed to come before it is 'textNeedTcl' above.
# Note that this command will try to load a suitable version of
# Tcltest if the package has not been loaded yet.
if {[lsearch [namespace children] ::tcltest] == -1} {
if {![catch {
package require tcltest $version
}]} {
namespace import -force ::tcltest::*
return
}
} elseif {[package vcompare [package present tcltest] $version] >= 0} {
namespace import -force ::tcltest::*
return
}
puts " Aborting the tests found in [file tail [info script]]."
puts " Requiring at least tcltest $version, have [package present tcltest]"
# This causes a 'return' in the calling scope.
return -code return
}
# Set up for Tk tests: enter the event loop long enough to catch
# any bgerrors.
proc tkbide {{msg "tkbide"} {msec 500}} {
set ::bideVar 0
set ::bideError ""
set ::bideErrorInfo ""
# It looks like update idletasks does the job.
if {0} {
after $msec {set ::bideVar 1}
tkwait variable ::bideVar
}
update idletasks
if {"" != $::bideError} {
error "$msg: $::bideError" $::bideErrorInfo
}
}
testsNeedTcl 8.6
testsNeedTcltest 2.2
interp alias {} type {} ::itcl::type
interp alias {} widget {} ::itcl::widget
# Marks tests which are only for Tk.
tcltest::testConstraint tk [expr {![catch {package require Tk}]}]
::tcltest::loadTestedCommands
package require itcl
#-----------------------------------------------------------------------
# Widgets
# A widget is just a widgetadaptor with an automatically created hull
# component (a Tk frame). So the widgetadaptor tests apply; all we
# need to test here is the frame creation.
test widget-1.1 {creating a widget
} -constraints {
tk
} -body {
widget myframe {
delegate method * to itcl_hull
delegate option * to itcl_hull
}
myframe create .frm -background green
set a [.frm cget -background]
set b [.frm itcl_hull]
destroy .frm
tkbide
list $a $b
} -cleanup {
myframe destroy
} -result {green ::itcl::internal::widgets::hull1.frm}
test widget-2.1 {can't redefine hull
} -constraints {
tk
} -body {
# there is no need to define or set itcl_hull as that is done automatically
widget myframe {
method resethull {} {
set itcl_hull ""
}
}
myframe .frm
.frm resethull
} -returnCodes {
error
} -cleanup {
myframe destroy
} -result {can't set "itcl_hull": The itcl_hull component cannot be redefined}
#-----------------------------------------------------------------------
# install
#
# The install command is used to install widget components, while getting
# options for the option database.
test install-1.1 {installed components are created properly
} -constraints {
tk
} -body {
widget myframe {
# Delegate an option just to make sure the component variable
# exists.
delegate option -font to text
constructor {args} {
installcomponent text using text $win.text -background green
}
method getit {} {
$win.text cget -background
}
}
myframe .frm
set a [.frm getit]
destroy .frm
tkbide
set a
} -cleanup {
myframe destroy
} -result {green}
test install-1.2 {installed components are saved properly
} -constraints {
tk
} -body {
widget myframe {
# Delegate an option just to make sure the component variable
# exists.
delegate option -font to text
constructor {args} {
installcomponent text using text $win.text -background green
}
method getit {} {
$text cget -background
}
}
myframe .frm
set a [.frm getit]
destroy .frm
tkbide
set a
} -cleanup {
myframe destroy
} -result {green}
test install-1.4 {install queries option database
} -constraints {
tk
} -body {
widget myframe {
delegate option -font to text
typeconstructor {
option add *Myframe.font Courier
}
constructor {args} {
installcomponent text using text $win.text
}
}
myframe .frm
set a [.frm cget -font]
destroy .frm
tkbide
set a
} -cleanup {
myframe destroy
} -result {Courier}
test install-1.5 {explicit options override option database
} -constraints {
tk
} -body {
widget myframe {
delegate option -font to text
typeconstructor {
option add *Myframe.font Courier
}
constructor {args} {
installcomponent text using text $win.text -font Times
}
}
myframe .frm
set a [.frm cget -font]
destroy .frm
tkbide
set a
} -cleanup {
myframe destroy
} -result {Times}
test install-1.6 {option db works with targetted options
} -constraints {
tk
} -body {
widget myframe {
delegate option -textfont to text as -font
typeconstructor {
option add *Myframe.textfont Courier
}
constructor {args} {
installcomponent text using text $win.text
}
}
myframe .frm
set a [.frm cget -textfont]
destroy .frm
tkbide
set a
} -cleanup {
myframe destroy
} -result {Courier}
test install-1.8 {install can install non-widget components
} -constraints {
tk
} -body {
type dog {
option -tailcolor black
}
widget myframe {
delegate option -tailcolor to thedog
typeconstructor {
option add *Myframe.tailcolor green
}
constructor {args} {
installcomponent thedog using dog $win.dog
}
}
myframe .frm
set a [.frm cget -tailcolor]
destroy .frm
tkbide
set a
} -cleanup {
dog destroy
myframe destroy
} -result {green}
test install-1.9 {ok if no options are delegated to component
} -constraints {
tk
} -body {
type dog {
option -tailcolor black
}
widget myframe {
constructor {args} {
installcomponent thedog using dog $win.dog
}
}
myframe .frm
destroy .frm
tkbide
# Test passes if no error is raised.
list ok
} -cleanup {
myframe destroy
dog destroy
} -result {ok}
test install-2.1 {
delegate option * for a non-shadowed option. The text widget's
-foreground and -font options should be set according to what's
in the option database on the widgetclass.
} -constraints {
tk
} -body {
widget myframe {
delegate option * to text
typeconstructor {
option add *Myframe.foreground red
option add *Myframe.font {Times 14}
}
constructor {args} {
installcomponent text using text $win.text
}
}
myframe .frm
set a [.frm cget -foreground]
set b [.frm cget -font]
destroy .frm
tkbide
list $a $b
} -cleanup {
myframe destroy
} -result {red {Times 14}}
test install-2.2 {
Delegate option * for a shadowed option. Foreground is declared
as a non-delegated option, hence it will pick up the option database
default. -foreground is not included in the "delegate option *", so
the text widget's -foreground option will not be set from the
option database.
} -constraints {
tk
} -body {
widget myframe {
option -foreground white
delegate option * to text
typeconstructor {
option add *Myframe.foreground red
}
constructor {args} {
installcomponent text using text $win.text
}
method getit {} {
$text cget -foreground
}
}
myframe .frm
set a [.frm cget -foreground]
set b [.frm getit]
destroy .frm
tkbide
expr {![string equal $a $b]}
} -cleanup {
myframe destroy
} -result {1}
test install-2.3 {
Delegate option * for a creation option. Because the text widget's
-foreground is set explicitly by the constructor, that always
overrides the option database.
} -constraints {
tk
} -body {
widget myframe {
delegate option * to text
typeconstructor {
option add *Myframe.foreground red
}
constructor {args} {
installcomponent text using text $win.text -foreground blue
}
}
myframe .frm
set a [.frm cget -foreground]
destroy .frm
tkbide
set a
} -cleanup {
myframe destroy
} -result {blue}
test install-2.4 {
Delegate option * with an excepted option. Because the text widget's
-state is excepted, it won't be set from the option database.
} -constraints {
tk
} -body {
widget myframe {
delegate option * to text except -state
typeconstructor {
option add *Myframe.foreground red
option add *Myframe.state disabled
}
constructor {args} {
installcomponent text using text $win.text
}
method getstate {} {
$text cget -state
}
}
myframe .frm
set a [.frm getstate]
destroy .frm
tkbide
set a
} -cleanup {
myframe destroy
} -result {normal}
#-----------------------------------------------------------------------
# Advanced installhull tests
#
# installhull is used to install the hull widget for both widgets and
# widget adaptors. It has two forms. In one form it installs a widget
# created by some third party; in this form no querying of the option
# database is needed, because we haven't taken responsibility for creating
# it. But in the other form (installhull using) installhull actually
# creates the widget, and takes responsibility for querying the
# option database as needed.
#
# NOTE: "installhull using" is always used to create a widget's hull frame.
#
# That options passed into installhull override those from the
# option database.
test installhull-1.1 {
options delegated to a widget's itcl_hull frame with the same name are
initialized from the option database. Note that there's no
explicit code in Snit to do this; it happens because we set the
-class when the widget was created. In fact, it happens whether
we delegate the option name or not.
} -constraints {
tk
} -body {
widget myframe {
delegate option -background to itcl_hull
typeconstructor {
option add *Myframe.background red
option add *Myframe.width 123
}
method getwid {} {
$itcl_hull cget -width
}
}
myframe .frm
set a [.frm cget -background]
set b [.frm getwid]
destroy .frm
tkbide
list $a $b
} -cleanup {
myframe destroy
} -result {red 123}
test installhull-1.2 {
Options delegated to a widget's itcl_hull frame with a different name are
initialized from the option database.
} -constraints {
tk
} -body {
widget myframe {
delegate option -mainbackground to itcl_hull as -background
typeconstructor {
option add *Myframe.mainbackground green
}
}
myframe .frm
set a [.frm cget -mainbackground]
destroy .frm
tkbide
set a
} -cleanup {
myframe destroy
} -result {green}
test option-5.1 {local widget options read from option database
} -constraints {
tk
} -body {
widget dog {
option -foo a
option -bar b
typeconstructor {
option add *Dog.bar bb
}
}
dog .fido
set a [.fido cget -foo]
set b [.fido cget -bar]
destroy .fido
tkbide
list $a $b
} -cleanup {
dog destroy
} -result {a bb}
test option-5.2 {local option database values available in constructor
} -constraints {
tk
} -body {
widget dog {
option -bar b
variable saveit
typeconstructor {
option add *Dog.bar bb
}
constructor {args} {
set saveit $itcl_options(-bar)
}
method getit {} {
return $saveit
}
}
dog .fido
set result [.fido getit]
destroy .fido
tkbide
set result
} -cleanup {
dog destroy
} -result {bb}
#-----------------------------------------------------------------------
# Setting the widget class explicitly
test widgetclass-1.3 {widgetclass must begin with uppercase letter
} -constraints {
tk
} -body {
widget dog {
widgetclass dog
}
} -returnCodes {
error
} -result {widgetclass "dog" does not begin with an uppercase letter}
test widgetclass-1.4 {widgetclass can only be defined once
} -constraints {
tk
} -body {
widget dog {
widgetclass Dog
widgetclass Dog
}
} -returnCodes {
error
} -result {too many widgetclass statements}
test widgetclass-1.5 {widgetclass set successfully
} -constraints {
tk
} -body {
widget dog {
widgetclass DogWidget
}
# The test passes if no error is thrown.
list ok
} -cleanup {
dog destroy
} -result {ok}
test widgetclass-1.6 {implicit widgetclass applied to hull
} -constraints {
tk
} -body {
widget dog {
typeconstructor {
option add *Dog.background green
}
method background {} {
$itcl_hull cget -background
}
}
dog .dog
set bg [.dog background]
destroy .dog
set bg
} -cleanup {
dog destroy
} -result {green}
test widgetclass-1.7 {explicit widgetclass applied to hull
} -constraints {
tk
} -body {
widget dog {
widgetclass DogWidget
typeconstructor {
option add *DogWidget.background yellow
}
method background {} {
$itcl_hull cget -background
}
}
dog .dog
set bg [.dog background]
destroy .dog
set bg
} -cleanup {
dog destroy
} -result {yellow}
#-----------------------------------------------------------------------
# hulltype statement
test hulltype-1.3 {hulltype can be frame
} -constraints {
tk
} -body {
widget dog {
delegate option * to itcl_hull
hulltype frame
}
dog .fido
catch {.fido configure -use} result
destroy .fido
tkbide
set result
} -cleanup {
dog destroy
} -result {unknown option "-use"}
test hulltype-1.4 {hulltype can be toplevel
} -constraints {
tk
} -body {
widget dog {
delegate option * to itcl_hull
hulltype toplevel
}
dog .fido
catch {.fido configure -use} result
destroy .fido
tkbide
set result
} -cleanup {
dog destroy
} -result {-use use Use {} {}}
test hulltype-1.5 {hulltype can only be defined once
} -constraints {
tk
} -body {
widget dog {
hulltype frame
hulltype toplevel
}
} -returnCodes {
error
} -result {too many hulltype statements}
test hulltype-2.1 {list of valid hulltypes
} -constraints {
tk
} -body {
type dog {
}
lsort [dog info hulltypes]
} -cleanup {
dog destroy
} -result {frame labelframe toplevel ttk:frame ttk:labelframe ttk:toplevel}
test winfo-10.1 {widget info widgets
} -constraints {
tk
} -body {
widget dog {
}
widget cat {
}
lsort [dog info widgets]
} -cleanup {
dog destroy
cat destroy
} -result {cat dog}
test winfo-10.2 {widget info components
} -constraints {
tk
} -body {
widget dog {
component comp1
component comp2
}
widget cat {
component comp1
component comp1a
}
set a [lsort [dog info components]]
set b [lsort [cat info components]]
list $a $b
} -cleanup {
dog destroy
cat destroy
} -result {{comp1 comp2 itcl_hull} {comp1 comp1a itcl_hull}}
test winfo-10.3 {widget info widgetclasses
} -constraints {
tk
} -body {
widget dog {
widgetclass DogWidget
}
widget cat {
widgetclass CatWidget
}
lsort [dog info widgetclasses]
} -cleanup {
dog destroy
cat destroy
} -result {CatWidget DogWidget}
#---------------------------------------------------------------------
# Clean up
::tcltest::cleanupTests
return