Subversion Repositories or1k

/interp.test

interp.test Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: defs =================================================================== --- defs (nonexistent) +++ defs (revision 1765) @@ -0,0 +1,343 @@ +# This file contains support code for the Tcl test suite. It is +# normally sourced by the individual files in the test suite before +# they run their tests. This improved approach to testing was designed +# and initially implemented by Mary Ann May-Pumphrey of Sun Microsystems. +# +# Copyright (c) 1990-1994 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) defs 1.44 96/10/08 17:26:58 + +if ![info exists VERBOSE] { + set VERBOSE 0 +} +if ![info exists TESTS] { + set TESTS {} +} + +# If tests are being run as root, issue a warning message and set a +# variable to prevent some tests from running at all. + +set user {} +if {$tcl_platform(platform) == "unix"} { + catch {set user [exec whoami]} + if {$user == ""} { + catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user} + } + if {$user == ""} {set user root} + if {$user == "root"} { + puts stdout "Warning: you're executing as root. I'll have to" + puts stdout "skip some of the tests, since they'll fail as root." + } +} + +# Some of the tests don't work on some system configurations due to +# differences in word length, file system configuration, etc. In order +# to prevent false alarms, these tests are generally only run in the +# master development directory for Tcl. The presence of a file +# "doAllTests" in this directory is used to indicate that the non-portable +# tests should be run. + +set doNonPortableTests [file exists doAllTests] + +# If there is no "memory" command (because memory debugging isn't +# enabled), generate a dummy command that does nothing. + +if {[info commands memory] == ""} { + proc memory args {} +} + +# Check configuration information that will determine which tests +# to run. To do this, create an array testConfig. Each element +# has a 0 or 1 value, and the following elements are defined: +# unixOnly - 1 means this is a UNIX platform, so it's OK +# to run tests that only work under UNIX. +# macOnly - 1 means this is a Mac platform, so it's OK +# to run tests that only work on Macs. +# pcOnly - 1 means this is a PC platform, so it's OK to +# run tests that only work on PCs. +# unixOrPc - 1 means this is a UNIX or PC platform. +# macOrPc - 1 means this is a Mac or PC platform. +# macOrUnix - 1 means this is a Mac or UNIX platform. +# nonPortable - 1 means this the tests are being running in +# the master Tcl/Tk development environment; +# Some tests are inherently non-portable because +# they depend on things like word length, file system +# configuration, window manager, etc. These tests +# are only run in the main Tcl development directory +# where the configuration is well known. The presence +# of the file "doAllTests" in this directory indicates +# that it is safe to run non-portable tests. +# tempNotPc - The inverse of pcOnly. This flag is used to +# temporarily disable a test. +# nonBlockFiles - 1 means this platform supports setting files into +# nonblocking mode. +# asyncPipeClose- 1 means this platform supports async flush and +# async close on a pipe. +# unixExecs - 1 means this machine has commands such as 'cat', +# 'echo' etc available. + +catch {unset testConfig} +if {$tcl_platform(platform) == "unix"} { + set testConfig(unixOnly) 1 + set testConfig(tempNotPc) 1 +} else { + set testConfig(unixOnly) 0 +} +if {$tcl_platform(platform) == "macintosh"} { + set testConfig(tempNotPc) 1 + set testConfig(macOnly) 1 +} else { + set testConfig(macOnly) 0 +} +if {$tcl_platform(platform) == "windows"} { + set testConfig(pcOnly) 1 +} else { + set testConfig(pcOnly) 0 +} +set testConfig(unixOrPc) [expr $testConfig(unixOnly) || $testConfig(pcOnly)] +set testConfig(macOrPc) [expr $testConfig(macOnly) || $testConfig(pcOnly)] +set testConfig(macOrUnix) [expr $testConfig(macOnly) || $testConfig(unixOnly)] +set testConfig(nonPortable) [file exists doAllTests] + +set f [open defs r] +if {[expr [catch {fconfigure $f -blocking off}]] == 0} { + set testConfig(nonBlockFiles) 1 +} else { + set testConfig(nonBlockFiles) 0 +} +close $f + +# Test for SCO Unix - cannot run async flushing tests because a potential +# problem with select is apparently interfering. (Mark Diekhans). + +if {$tcl_platform(platform) == "unix"} { + if {[catch {exec uname -X | fgrep {Release = 3.2v}}] == 0} { + set testConfig(asyncPipeClose) 0 + } else { + set testConfig(asyncPipeClose) 1 + } +} else { + set testConfig(asyncPipeClose) 1 +} + +# Test to see if execed commands such as cat, echo, rm and so forth are +# present on this machine. + +set testConfig(unixExecs) 1 +if {$tcl_platform(platform) == "macintosh"} { + set testConfig(unixExecs) 0 +} +if {($testConfig(unixExecs) == 1) && ($tcl_platform(platform) == "windows")} { + if {[catch {exec cat defs}] == 1} { + set testConfig(unixExecs) 0 + } + if {($testConfig(unixExecs) == 1) && ([catch {exec echo hello}] == 1)} { + set testConfig(unixExecs) 0 + } + if {($testConfig(unixExecs) == 1) && \ + ([catch {exec sh -c echo hello}] == 1)} { + set testConfig(unixExecs) 0 + } + if {($testConfig(unixExecs) == 1) && ([catch {exec wc defs}] == 1)} { + set testConfig(unixExecs) 0 + } + if {$testConfig(unixExecs) == 1} { + exec echo hello > removeMe + if {[catch {exec rm removeMe}] == 1} { + set testConfig(unixExecs) 0 + } + } + if {($testConfig(unixExecs) == 1) && ([catch {exec sleep 1}] == 1)} { + set testConfig(unixExecs) 0 + } + if {($testConfig(unixExecs) == 1) && \ + ([catch {exec fgrep unixExecs defs}] == 1)} { + set testConfig(unixExecs) 0 + } + if {($testConfig(unixExecs) == 1) && ([catch {exec ps}] == 1)} { + set testConfig(unixExecs) 0 + } + if {($testConfig(unixExecs) == 1) && \ + ([catch {exec echo abc > removeMe}] == 0) && \ + ([catch {exec chmod 644 removeMe}] == 1) && \ + ([catch {exec rm removeMe}] == 0)} { + set testConfig(unixExecs) 0 + } else { + catch {exec rm -f removeMe} + } + if {($testConfig(unixExecs) == 1) && \ + ([catch {exec mkdir removeMe}] == 1)} { + set testConfig(unixExecs) 0 + } else { + catch {exec rm -r removeMe} + } + if {$testConfig(unixExecs) == 0} { + puts stdout "Warning: Unix-style executables are not available, so" + puts stdout "some tests will be skipped." + } +} + +proc print_verbose {name description script code answer} { + puts stdout "\n" + puts stdout "==== $name $description" + puts stdout "==== Contents of test case:" + puts stdout "$script" + if {$code != 0} { + if {$code == 1} { + puts stdout "==== Test generated error:" + puts stdout $answer + } elseif {$code == 2} { + puts stdout "==== Test generated return exception; result was:" + puts stdout $answer + } elseif {$code == 3} { + puts stdout "==== Test generated break exception" + } elseif {$code == 4} { + puts stdout "==== Test generated continue exception" + } else { + puts stdout "==== Test generated exception $code; message was:" + puts stdout $answer + } + } else { + puts stdout "==== Result was:" + puts stdout "$answer" + } +} + +# test -- +# This procedure runs a test and prints an error message if the +# test fails. If VERBOSE has been set, it also prints a message +# even if the test succeeds. The test will be skipped if it +# doesn't match the TESTS variable, or if one of the elements +# of "constraints" turns out not to be true. +# +# Arguments: +# name - Name of test, in the form foo-1.2. +# description - Short textual description of the test, to +# help humans understand what it does. +# constraints - A list of one or more keywords, each of +# which must be the name of an element in +# the array "testConfig". If any of these +# elements is zero, the test is skipped. +# This argument may be omitted. +# script - Script to run to carry out the test. It must +# return a result that can be checked for +# correctness. +# answer - Expected result from script. + +proc test {name description script answer args} { + global VERBOSE TESTS testConfig + if {[string compare $TESTS ""] != 0} then { + set ok 0 + foreach test $TESTS { + if [string match $test $name] then { + set ok 1 + break + } + } + if !$ok then return + } + set i [llength $args] + if {$i == 0} { + # Empty body + } elseif {$i == 1} { + # "constraints" argument exists; shuffle arguments down, then + # make sure that the constraints are satisfied. + + set constraints $script + set script $answer + set answer [lindex $args 0] + foreach constraint $constraints { + if {![info exists testConfig($constraint)] + || !$testConfig($constraint)} { + return + } + } + } else { + error "wrong # args: must be \"test name description ?constraints? script answer\"" + } + memory tag $name + set code [catch {uplevel $script} result] + if {$code != 0} { + print_verbose $name $description $script \ + $code $result + } elseif {[string compare $result $answer] == 0} then { + if $VERBOSE then { + if {$VERBOSE > 0} { + print_verbose $name $description $script \ + $code $result + } + puts stdout "++++ $name PASSED" + } + } else { + print_verbose $name $description $script \ + $code $result + puts stdout "---- Result should have been:" + puts stdout "$answer" + puts stdout "---- $name FAILED" + } +} + +proc dotests {file args} { + global TESTS + set savedTests $TESTS + set TESTS $args + source $file + set TESTS $savedTests +} + +proc normalizeMsg {msg} { + regsub "\n$" [string tolower $msg] "" msg + regsub -all "\n\n" $msg "\n" msg + regsub -all "\n\}" $msg "\}" msg + return $msg +} + +proc makeFile {contents name} { + set fd [open $name w] + fconfigure $fd -translation lf + if {[string index $contents [expr [string length $contents] - 1]] == "\n"} { + puts -nonewline $fd $contents + } else { + puts $fd $contents + } + close $fd +} + +proc removeFile {name} { + file delete $name +} + +proc makeDirectory {name} { + file mkdir $name +} + +proc removeDirectory {name} { + file delete -force $name +} + +proc viewFile {name} { + global tcl_platform testConfig + if {($tcl_platform(platform) == "macintosh") || \ + ($testConfig(unixExecs) == 0)} { + set f [open $name] + set data [read -nonewline $f] + close $f + return $data + } else { + exec cat $name + } +} + +# Locate tcltest executable + +set tcltest [list [info nameofexecutable]] +if {$tcltest == "{}"} { + set tcltest {} + puts "Unable to find tcltest executable, multiple process tests will fail." +} + +

defs Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: widget.test =================================================================== --- widget.test (nonexistent) +++ widget.test (revision 1765) @@ -0,0 +1,243 @@ +# +# Tests for [incr Tk] widgets based on itk::Widget +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id: widget.test,v 1.1.1.1 2002-01-16 10:24:48 markom 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} + +# ---------------------------------------------------------------------- +# Simple mega-widget +# ---------------------------------------------------------------------- +test widget-1.1 {define a simple mega-widget class} { + option add *TestWidget.background linen + option add *TestWidget.borderWidth 2 + option add *TestWidget.command "" + option add *TestWidget.cursor "" + option add *TestWidget.foreground navy + option add *TestWidget.highlight white + option add *TestWidget.normal ivory + option add *TestWidget.text "" + + itcl::class TestWidget { + inherit itk::Widget + constructor {args} { + itk_component add test1 { + label $itk_interior.t1 + } { + keep -background -foreground -cursor + keep -text + } + pack $itk_component(test1) -side left -padx 2 + + itk_component add test2 { + button $itk_interior.t2 -text "Push Me" + } { + keep -foreground -cursor -borderwidth -command + rename -background -normal normal Background + rename -activebackground -highlight highlight Foreground + } + pack $itk_component(test2) -side right -fill x -pady 2 + + eval itk_initialize $args + } + private variable status "" + public method action {info} { + lappend status $info + } + + public method do {cmd} { + eval $cmd + } + + itk_option define -status status Status {} { + lappend status $itk_option(-status) + } + } + TestWidget .#auto +} {.testWidget0} + +pack .testWidget0 + +test widget-1.2 {check the list of configuration options} { + .testWidget0 configure +} {{-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 {} {}}} + +set unique 0 +foreach test { + {-background {-background background Background linen linen}} + {-borderwidth {-borderwidth borderWidth BorderWidth 2 2}} + {-clientdata {-clientdata clientData ClientData {} {}}} + {-command {-command command Command {} {}}} + {-cursor {-cursor cursor Cursor {} {}}} + {-foreground {-foreground foreground Foreground navy navy}} + {-highlight {-highlight highlight Foreground white white}} + {-normal {-normal normal Background ivory ivory}} + {-status {-status status Status {} {}}} + {-text {-text text Text {} {}}} +} { + set opt [lindex $test 0] + set result [lindex $test 1] + + test widget-1.3.[incr unique] {check individual configuration options} { + .testWidget0 configure $opt + } $result +} + +set unique 0 +foreach test { + {-background red} + {-borderwidth 1} + {-clientdata "foo bar"} + {-command {puts "hello!"}} + {-cursor trek} + {-foreground IndianRed} + {-highlight MistyRose} + {-normal MistyRose2} + {-status "test message"} + {-text "Label:"} +} { + set opt [lindex $test 0] + set value [lindex $test 1] + + test widget-1.4.[incr unique] {set individual configuration options} { + list [.testWidget0 configure $opt $value] \ + [.testWidget0 cget $opt] \ + [.testWidget0 do "set itk_option($opt)"] + } [list "" $value $value] +} + +test widget-1.5 {check the list components} { + lsort [.testWidget0 component] +} {hull test1 test2} + +set unique 0 +foreach test { + {hull .testWidget0} + {test1 .testWidget0.t1} + {test2 .testWidget0.t2} +} { + set name [lindex $test 0] + set win [lindex $test 1] + + test widget-1.6 {check the window for each component} { + list [.testWidget0 component $name] \ + [.testWidget0 do "set itk_component($name)"] + } [list $win $win] +} + +test widget-1.7 {check the propagation of configuration options} { + list [.testWidget0 component hull cget -cursor] \ + [.testWidget0 component test1 cget -cursor] \ + [.testWidget0 component test2 cget -cursor] +} {trek trek trek} + +test widget-1.8 {check the propagation of configuration options} { + list [.testWidget0 component hull cget -background] \ + [.testWidget0 component test1 cget -background] \ + [.testWidget0 component test2 cget -background] +} {red red MistyRose2} + +test widget-1.9 {check the propagation of configuration options} { + list [.testWidget0 component test1 cget -text] \ + [.testWidget0 component test2 cget -text] +} {Label: {Push Me}} + +test widget-1.10 {check the invocation of "config" code} { + .testWidget0 do {set status} +} {{} {test message}} + +test widget-1.11a {configure using the "code" command} { + .testWidget0 do {configure -command [code $this action "button press"]} + .testWidget0 cget -command +} {namespace inscope ::TestWidget {::.testWidget0 action {button press}}} + +test widget-1.11b {execute some code created by "code" command} { + .testWidget0 do {set status ""} + .testWidget0 component test2 invoke + .testWidget0 configure -status "in between" + .testWidget0 component test2 invoke + .testWidget0 do {set status} +} {{button press} {in between} {button press}} + +test widget-1.12a {components can be added on the fly} { + .testWidget0 do { + itk_component add test3 { + label $itk_interior.t3 -text "Temporary" + } { + keep -background -foreground -cursor + } + } +} {test3} + +test widget-1.12b {components can be added on the fly} { + .testWidget0 do { + pack $itk_component(test3) -fill x + } +} {} + +test widget-1.13 {new components show up on the component list} { + lsort [.testWidget0 component] +} {hull test1 test2 test3} + +test widget-1.14 {new components are initialized properly} { + list [.testWidget0 component test3 cget -background] \ + [.testWidget0 component test3 cget -foreground] \ + [.testWidget0 component test3 cget -cursor] +} {red IndianRed trek} + +test widget-1.15 {components can be deleted like ordinary widgets} { + destroy [.testWidget0 component test3] +} {} + +test widget-1.16 {dead components are removed from the component list} { + lsort [.testWidget0 component] +} {hull test1 test2} + +test widget-1.17 {use "configbody" command to change "config" code} { + configbody TestWidget::status {lappend status "new"} +} {} + +test widget-1.18 {"config" code can really change} { + .testWidget0 do {set status ""} + .testWidget0 configure -status "test message" + .testWidget0 configure -status "another" + .testWidget0 do {set status} +} {new new} + +test widget-1.19 {"config" code can change back} { + configbody TestWidget::status {lappend status $itk_option(-status)} +} {} + +test widget-1.20 {mega-widgets show up on the object list} { + itcl::find objects .testWidget* +} {.testWidget0} + +test widget-1.21 {when a mega-widget is destroyed, its object is deleted} { + destroy .testWidget0 + itcl::find objects .testWidget* +} {} + +test widget-1.22 {recreate a test widget} { + TestWidget .testWidget0 + itcl::find objects .testWidget* +} {.testWidget0} + +test widget-1.23 {when an object is deleted the widget is destroyed} { + itcl::delete object .testWidget0 + winfo exists .testWidget0 +} {0} + +# ---------------------------------------------------------------------- +# Clean up +# ---------------------------------------------------------------------- +itcl::delete class TestWidget

widget.test Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: option.test =================================================================== --- option.test (nonexistent) +++ option.test (revision 1765) @@ -0,0 +1,179 @@ +# +# Basic tests for [incr Tk] mega-widgets +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id: option.test,v 1.1.1.1 2002-01-16 10:24:48 markom 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} + +# ---------------------------------------------------------------------- +# Component option processing +# ---------------------------------------------------------------------- +test option-1.1 {create a widget for the following tests} { + itcl::class TestOptComp { + inherit itk::Widget + 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 + } + private variable status "" + public method action {info} { + lappend status $info + } + public method do {cmd} { + eval $cmd + } + itk_option define -status status Status {} { + lappend status $itk_option(-status) + } + } + + itcl::class TestOptWidget { + inherit itk::Widget + 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 + } + } + TestOptWidget .#auto +} {.testOptWidget0} + +test option-1.2 {"keep" can be called more than once} { + .testOptWidget0 do { + itk_component add k0 { + TestOptComp $itk_interior.k0 -status "create" + } { + keep -background -foreground -cursor + keep -background -foreground -cursor + keep -status + keep -status + } + pack $itk_component(k0) + } + .testOptWidget0 configure -status "foo" + .testOptWidget0 component k0 do {set status} +} {create foo} + +test option-1.3 {"rename" can be called more than once} { + .testOptWidget0 do { + itk_component add k1 { + TestOptComp $itk_interior.k1 -status "create" + } { + rename -status -test test Test + rename -status -test test Test + } + pack $itk_component(k1) + } + .testOptWidget0 configure -test "bar" + .testOptWidget0 component k1 do {set status} +} {create bar} + +test option-1.4 {"ignore" overrides keep and rename} { + .testOptWidget0 do { + itk_component add k2 { + TestOptComp $itk_interior.k2 -status "create" + } { + keep -status + rename -status -test test Test + ignore -status + } + pack $itk_component(k2) + } + .testOptWidget0 configure -status k2 -test k2 + .testOptWidget0 component k2 do {set status} +} {create foo bar} + +# ---------------------------------------------------------------------- +# Option processing with "usual" command +# ---------------------------------------------------------------------- +test option-2.1 {create a widget for the following tests} { + TestOptComp .testUsual +} {.testUsual} + +test option-2.2 {register some "usual" code} { + usual TestOptComp-test {keep -cursor -foreground} +} {} + +test option-2.3 {query back "usual" code} { + usual TestOptComp-test +} {keep -cursor -foreground} + +test option-2.4 {query back unknown "usual" code} { + usual xyzzyxyzzy +} {} + +test option-2.5 {add a component using "usual" code} { + .testUsual do { + itk_component add u0 { + label $itk_interior.u0 -text "Usual Test #0" + } { + usual TestOptComp-test + } + pack $itk_component(u0) + } + .testUsual configure -foreground green -cursor gumby + + list [.testUsual component u0 cget -foreground] \ + [.testUsual component u0 cget -cursor] +} {green gumby} + +test option-2.6 {override "usual" options} { + .testUsual do { + itk_component add u1 { + label $itk_interior.u1 -text "Usual Test #1" + } { + usual TestOptComp-test + ignore -cursor + keep -background + } + pack $itk_component(u1) + } + .testUsual configure -foreground red -background white -cursor dot + + list [.testUsual component u1 cget -foreground] \ + [.testUsual component u1 cget -background] \ + [.testUsual component u1 cget -cursor] +} {red white gumby} + +set unique 0 +foreach widget {button canvas checkbutton entry frame label listbox + menu menubutton message radiobutton scale scrollbar + text toplevel} { + set name "c[incr unique]" + test option-2.7.$name {verify "usual" options for all Tk widgets} { + .testUsual do [format { + itk_component add %s { + %s $itk_interior.%s + } + } $name $widget $name] + } $name +} + +# ---------------------------------------------------------------------- +# Clean up +# ---------------------------------------------------------------------- +itcl::delete class TestOptComp TestOptWidget

option.test Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: all =================================================================== --- all (nonexistent) +++ all (revision 1765) @@ -0,0 +1,16 @@ +# This file contains a top-level script to run all of the Tcl +# tests. Execute it by invoking "source all" when running tclTest +# in this directory. +# +# SCCS: @(#) all 1.7 96/02/16 08:55:38 + +foreach i [lsort [glob *.test]] { + if [string match l.*.test $i] { + # This is an SCCS lock file; ignore it. + continue + } + puts stdout $i + if [catch {source $i} msg] { + puts $msg + } +}

all Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: toplevel.test =================================================================== --- toplevel.test (nonexistent) +++ toplevel.test (revision 1765) @@ -0,0 +1,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.1.1 2002-01-16 10:24:48 markom 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

toplevel.test Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: privacy.test =================================================================== --- privacy.test (nonexistent) +++ privacy.test (revision 1765) @@ -0,0 +1,94 @@ +# +# Privacy options for components +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id: privacy.test,v 1.1.1.1 2002-01-16 10:24:48 markom 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} + +# ---------------------------------------------------------------------- +# Define a base class with public variables and a simple mega-widget +# ---------------------------------------------------------------------- +test privacy-1.1 {define simple mega-widget class} { + itcl::class TestPrivacy { + inherit itk::Widget + constructor {args} { + eval itk_initialize $args + } + method do {args} { + return [eval $args] + } + } + set testobj [TestPrivacy .#auto] + pack $testobj +} {} + +test privacy-1.2 {"itk_component add" requires certain arguments} { + list [catch {$testobj do itk_component add foo} msg] $msg \ + [catch {$testobj do itk_component add foo bar baz qux} msg] $msg +} {1 {wrong # args: should be "itk_component add ?-protected? ?-private? ?--? name createCmds ?optionCmds?"} 1 {wrong # args: should be "add ?-protected? ?-private? ?--? name createCmds ?optionCmds?}} + +test privacy-1.3 {"itk_component add" rejects invalid options} { + list [catch { + $testobj do itk_component add -foo bar baz qux + } msg] $msg \ + [catch { + $testobj do itk_component add -- -foo {label $itk_interior.l} + } msg] $msg +} {1 {bad option "-foo": should be -private, -protected or --} 0 -foo} + +test privacy-1.4 {"itk_component add" recognizes privacy options} { + list [catch { + $testobj do itk_component add -protected x {label $itk_interior.x} + } msg] $msg \ + [catch { + $testobj do itk_component add -private y {label $itk_interior.y} + } msg] $msg +} {0 x 0 y} + +test privacy-1.5 {protected/private components are hidden} { + list [lsort [$testobj component]] \ + [lsort [$testobj do component]] +} {{-foo hull} {-foo hull x y}} + +test privacy-1.6 {define a derived class and add protected/private comps} { + itcl::class TestMorePrivacy { + inherit TestPrivacy + constructor {args} { + eval itk_initialize $args + } + method do {args} { + return [eval $args] + } + } + set testobj2 [TestMorePrivacy .#auto] + $testobj2 TestPrivacy::do itk_component add -private x { + label $itk_interior.x + } + $testobj2 TestPrivacy::do itk_component add -protected y { + label $itk_interior.y + } + $testobj2 TestPrivacy::do itk_component add z { + label $itk_interior.z + } +} {z} + +test privacy-1.7 {components are visible depending on namespace context} { + list [lsort [$testobj2 component]] \ + [lsort [$testobj2 do component]] \ + [lsort [$testobj2 TestPrivacy::do component]] +} {{hull z} {hull y z} {hull x y z}} + +# ---------------------------------------------------------------------- +# Clean up +# ---------------------------------------------------------------------- +itcl::delete class TestPrivacy TestMorePrivacy

privacy.test Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: public.test =================================================================== --- public.test (nonexistent) +++ public.test (revision 1765) @@ -0,0 +1,75 @@ +# +# 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.1.1.1 2002-01-16 10:24:48 markom 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} + +# ---------------------------------------------------------------------- +# 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 {} {}} + +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

public.test Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property