diff options
Diffstat (limited to 'tix/tests')
66 files changed, 4390 insertions, 0 deletions
diff --git a/tix/tests/Driver.tcl b/tix/tests/Driver.tcl new file mode 100644 index 00000000000..5f5372a138e --- /dev/null +++ b/tix/tests/Driver.tcl @@ -0,0 +1,356 @@ +# This is the "Test Driver" program that sources in each test script. It +# must be invoked by the test/Test.tcl program (in Unix) or by a properly +# configured wish.exe program (in Wondows). +# + +catch { + cd [file dirname [info script]] +} + +set oldglobals {} +set oldglobals [info globals] + +# Some parts of the test execute tests for a specific platform. The variable +# tixPriv(test:platform) controls the tests for which platform should +# be executed. This can be controlled by the TEST_PLATFORM environment +# variable + +set tixPriv(test:platform) unix +if [info exists tcl_platform(platform)] { + if {$tcl_platform(platform) == "windows"} { + set tixPriv(test:platform) windows + } +} + +if [info exists env(TEST_PLATFORM)] { + set tixPriv(test:platform) $env(TEST_PLATFORM) +} + +global testConfig +if {![info exists tix]} { + if ![info exists tcl_platform(platform)] { + puts "ERROR: this version of wish doesn't support dynamic loading" + exit -1 + } + + # This must have been executed by a plain wish expecting to + # dynamic load Tix. + + puts -nonewline "trying to dynamically load Tix ... " + + global tk_version + if {$tcl_platform(platform) == "unix"} { + case $tk_version { + 4.1 { + set testConfig(dynlib) \ + ../unix/tk4.1/libtix4.1.4.1[info sharedlibextension] + } + 4.2 { + set testConfig(dynlib) \ + ../unix/tk4.2/libtix4.1.4.2[info sharedlibextension] + } + } + } else { + case $tk_version { + 4.1 { + set testConfig(dynlib) ..\\win\\tix41.dll + } + 4.2 { + set testConfig(dynlib) ..\\win\\tix41.dll + } + } + } + + if [info exists testConfig(dynlib)] { + load $testConfig(dynlib) Tix + } + + if {[info exists tix]} { + puts succeeded + } else { + puts failed + exit + } +} else { + set testConfig(dynlib) "" +} + +proc Driver:Test {name f} { + global oldglobals errorInfo testConfig + + foreach w [winfo children .] { + if [string comp .__top $w] { + destroy $w + } + } + + foreach g [info globals] { + if {[lsearch $oldglobals $g] == -1} { +# uplevel #0 unset $g + } + } + + if {$testConfig(VERBOSE) >= 20} { + puts ------------------------------------------------------------ + puts "Loading script $name" + } else { + puts $name + } + + update + uplevel #0 source $f + Event-Initialize + catch { + wm title . [About] + if {$testConfig(VERBOSE) >= 20} { + puts " [About]" + puts "---------------------starting-------------------------------" + } + } + + set code [catch { + Test + } error] + + if $code { + if {$code == 1234} { + puts -nonewline "Test $f is aborted" + } else { + puts -nonewline "Test $f is aborted unexpectedly" + } + if {[info exists errorInfo] && ![tixStrEq $errorInfo ""]} { + puts " by the following error\n$errorInfo" + } else { + puts "." + } + } + Done +} + +# fileList: name of the file that contains a list of test targets +# type: "dir" or "script" +# +proc Driver:GetTargets {fileList type} { + set fd [open $fileList {RDONLY}] + set data {} + + while {![eof $fd]} { + set line [string trim [gets $fd]] + if [regexp ^# $line] { + continue + } + append data $line\n + } + + close $fd + set files {} + + foreach item $data { + set takeit 1 + + foreach cond [lrange $item 1 end] { + set inverse 0 + set cond [string trim $cond] + if {[string index $cond 0] == "!"} { + set cond [string range $cond 1 end] + set inverse 1 + } + + set true 1 + case [lindex $cond 0] { + c { + set cmd [lindex $cond 1] + if {[info command $cmd] != $cmd} { + if ![auto_load $cmd] { + set true 0 + } + } + } + i { + if {[lsearch [image types] [lindex $cond 1]] == -1} { + set true 0 + } + } + v { + set var [lindex $cond 1] + if ![uplevel #0 info exists [list $var]] { + set true 0 + } + } + default { + # must be an expression + # + if ![uplevel #0 expr [list $cond]] { + set true 0 + } + } + } + + if {$inverse} { + set true [expr !$true] + } + if {!$true} { + set takeit 0 + break + } + } + + if {$takeit} { + lappend files [lindex $item 0] + } + } + return $files +} + +proc Driver:Main {} { + global argv env + + if [tixStrEq $argv "dont"] { + return + } + + set argvfiles $argv + set env(WAITTIME) 200 + + set errCount 0 + + set PWD [pwd] + if {$argvfiles == {}} { + set argvfiles [Driver:GetTargets files dir] + } + + foreach f $argvfiles { + Driver:Execute $f + cd $PWD + } +} + +proc Driver:Execute {f} { + global testConfig + + if [file isdir $f] { + raise . + set dir $f + + if {$testConfig(VERBOSE) >= 20} { + puts "Entering directory $dir ..." + } + cd $dir + + if [file exists pkginit.tcl] { + # call the package initialization file, which is + # something specific to the files in this directory + # + source pkginit.tcl + } + foreach f [Driver:GetTargets files script] { + set _PWD [pwd] + Driver:Test $dir/$f $f + cd $_PWD + } + if {$testConfig(VERBOSE) >= 20} { + puts "Leaving directory $dir ..." + } + } else { + set dir [file dirname $f] + if {$dir != {}} { + if {$testConfig(VERBOSE) >= 20} { + puts "Entering directory $dir ..." + } + cd $dir + if [file exists pkginit.tcl] { + # call the package initialization file, which is + # something specific to the files in this directory + # + source pkginit.tcl + } + set f [file tail $f] + } + set _PWD [pwd] + Driver:Test $f $f + cd $_PWD + + if {$testConfig(VERBOSE) >= 20} { + puts "Leaving directory $dir ..." + } + } +} + +if [tixStrEq [tix platform] "windows"] { + # The following are a bunch of useful functions to make it more convenient + # to run the tests on Windows inside the Tix console window. + # + + # do -- + # + # Execute a test. + # + proc do {f} { + set PWD [pwd] + Driver:Execute $f + cd $PWD + puts "% " + } + + # rnew -- + # + # Read in all the files in the Tix library path that has been modified. + # + proc rnew {} { + global lastModified filesPatterns + foreach file [eval glob $filesPatterns] { + set mtime [file mtime $file] + if {$lastModified < $mtime} { + set lastModified $mtime + puts "sourcing $file" + uplevel #0 source [list $file] + } + } + } + + # pk -- + # + # pack widgets filled and expanded + proc pk {args} { + eval pack $args -expand yes -fill both + } + + # Initialize the lastModified so that rnew only loads in newly modified + # files + # + set filesPatterns {../library/*.tcl Driver.tcl library/*.tcl} + set lastModified 0 + foreach file [eval glob $filesPatterns] { + set mtime [file mtime $file] + if {$lastModified < $mtime} { + set lastModified $mtime + } + } + + proc ei {} { + global errorInfo + puts $errorInfo + } +} + + +uplevel #0 source library/TestLib.tcl +uplevel #0 source library/CaseData.tcl +wm title . "Test-driving Tix" +Driver:Main + +puts "$testConfig(errCount) error(s) found" + +if {[tix platform] != "windows"} { + destroy . + catch { + update + } + exit 0 +} else { + puts -nonewline "type \"exit\" to quit the test\n% " + proc q {} { + exit + } +} + diff --git a/tix/tests/Makefile.in b/tix/tests/Makefile.in new file mode 100644 index 00000000000..771f6deaa5a --- /dev/null +++ b/tix/tests/Makefile.in @@ -0,0 +1,198 @@ +# This file is a Makefile for Tix. If it has the name +# "Makefile.in" Then it is a template for a Makefile; to +# generate the actual Makefile, run "./configure", which is a +# configuration script generated by the "autoconf" program +# (constructs like "@foo@" will get replaced in the actual +# Makefile. +# +# See the file README for information about executing the test +# suites. +# +# Copyright (c) 1996, Expert Interface Technologies +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# +@SET_MAKE@ + +BINSRC_DIR = @SRC_DIR@ +SRC_DIR = @SRC_DIR@ +LIBRARY_DIR = @SRC_DIR@/library +DEMOS_DIR = @SRC_DIR@/demos +MANUAL_DIR = @SRC_DIR@/man +VPATH = @SRC_DIR@ + +all: @TIX_TARGETS@ @TIX_TEST_LOAD@ + +test: all + +unix-tk4.0:: tk40 + +unix-tk4.1:: tk41 + +unix-tk4.2:: tk42 + +unix-itcl2.0:: itcl20 + +unix-itcl2.1:: itcl21 + +# There are no test for the following targets (they don't really need +# tests) +unix-et-tk4.0:: + +unix-et-tk4.1:: + +demos-c:: + +# Some versions of make, like SGI's, use the following variable to +# determine which shell to use for executing commands: +SHELL = @SHELL@ + +SUBSETS= + +ENVIRON_74 = TEST_TCL_LIBRARY=@TCL74_SRC_DIR@/library \ + TEST_TK_LIBRARY=@TK40_SRC_DIR@/library \ + TEST_ITCL_LIBRARY=@ITCL20_SRC_DIR@/itcl/library \ + TEST_ITK_LIBRARY=@ITCL20_SRC_DIR@/itk/library \ + IWIDGETS_LIBRARY=@ITCL20_SRC_DIR@/iwidgets2.0.0 \ + TIX_LIBRARY=@SRC_DIR@/library \ + TEST_BINSRC_DIR=$(BINSRC_DIR) \ + TEST_LDPATHS="" + + +ENVIRON_75 = TEST_TCL_LIBRARY=@TCL75_SRC_DIR@/library \ + TEST_TK_LIBRARY=@TK41_SRC_DIR@/library \ + TEST_ITCL_LIBRARY=@ITCL20_SRC_DIR@/itcl/library \ + TEST_ITK_LIBRARY=@ITCL20_SRC_DIR@/itk/library \ + IWIDGETS_LIBRARY=@ITCL20_SRC_DIR@/iwidgets2.0.0 \ + TIX_LIBRARY=@SRC_DIR@/library \ + TEST_BINSRC_DIR=$(BINSRC_DIR) \ + TEST_LDPATHS=@TCL75_SRC_DIR@/unix:@TK41_SRC_DIR@/unix:$(BINSRC_DIR)/unix-tk4.1 + + +ENVIRON_76 = TEST_TCL_LIBRARY=@TCL76_SRC_DIR@/library \ + TEST_TK_LIBRARY=@TK42_SRC_DIR@/library \ + TEST_ITCL_LIBRARY=@ITCL20_SRC_DIR@/itcl/library \ + TEST_ITK_LIBRARY=@ITCL20_SRC_DIR@/itk/library \ + IWIDGETS_LIBRARY=@ITCL20_SRC_DIR@/iwidgets2.0.0 \ + TIX_LIBRARY=@SRC_DIR@/library \ + TEST_BINSRC_DIR=$(BINSRC_DIR) \ + TEST_LDPATHS=@TCL76_SRC_DIR@/unix:@TK42_SRC_DIR@/unix:$(BINSRC_DIR)/unix-tk4.2 + +ENVIRON_ITCL_20 = TEST_TCL_LIBRARY=@ITCL20_SRC_DIR@/tcl7.4/library \ + TEST_TK_LIBRARY=@ITCL20_SRC_DIR@/tk4.0/library \ + TEST_ITCL_LIBRARY=@ITCL20_SRC_DIR@/itcl/library \ + TEST_ITK_LIBRARY=@ITCL20_SRC_DIR@/itk/library \ + IWIDGETS_LIBRARY=@ITCL20_SRC_DIR@/iwidgets2.0.0 \ + TIX_LIBRARY=@SRC_DIR@/library \ + TEST_BINSRC_DIR=$(BINSRC_DIR) \ + TEST_LDPATHS="" + +ENVIRON_ITCL_21 = TEST_TCL_LIBRARY=@ITCL21_SRC_DIR@/tcl7.5/library \ + TEST_TK_LIBRARY=@ITCL21_SRC_DIR@/tk4.1/library \ + TEST_ITCL_LIBRARY=@ITCL21_SRC_DIR@/itcl/library \ + TEST_ITK_LIBRARY=@ITCL21_SRC_DIR@/itk/library \ + IWIDGETS_LIBRARY=@ITCL21_SRC_DIR@/iwidgets2.1.0 \ + TIX_LIBRARY=@SRC_DIR@/library \ + TEST_BINSRC_DIR=$(BINSRC_DIR) \ + TEST_LDPATHS=@ITCL21_SRC_DIR@/itk/unix:@ITCL21_SRC_DIR@/itcl/unix:@ITCL21_SRC_DIR@/tcl7.5/unix:@ITCL21_SRC_DIR@/tk4.1/unix:$(BINSRC_DIR)/unix-itcl2.1 + +tk40:: + @$(ENVIRON_74) \ + tclsh Test.tcl tk40 $(SUBSETS) + +tk41:: + @$(ENVIRON_75) \ + tclsh Test.tcl tk41 $(SUBSETS) + +tk42:: + @$(ENVIRON_76) \ + tclsh Test.tcl tk42 $(SUBSETS) + +itcl20:: + @$(ENVIRON_ITCL_20) \ + tclsh Test.tcl itcl20 $(SUBSETS) + +itcl21:: + @$(ENVIRON_ITCL_21) \ + tclsh Test.tcl itcl21 $(SUBSETS) + +load:: + @$(ENVIRON_75) \ + tclsh Test.tcl load $(SUBSETS) + +Makefile: Makefile.in + cd $(SRC_DIR); $(SHELL) config.status + +distclean: + - rm -f Makefile + +#---------------------------------------------------------------------- +# +# Testing the files in the binary distribution +# +#---------------------------------------------------------------------- + +dist: dist_tk40 dist_tk41 dist_itcl20 dist_itcl21 + +BDIST=$(TIX_BIN_DIST_DIR) +SDIST=$(TIX_SRC_DIST_DIR) + +ENV_TK40_DIST = \ + TIX_LIBRARY=$(SDIST)/library \ + TCL_LIBRARY=@TCL74_SRC_DIR@/library \ + TK_LIBRARY=@TK40_SRC_DIR@/library \ + LD_LIBRARY_PATH=$(SITE_LDPATH) + +ENV_TK41_DIST = \ + TIX_LIBRARY=$(SDIST)/library \ + TCL_LIBRARY=@TCL75_SRC_DIR@/library \ + TK_LIBRARY=@TK41_SRC_DIR@/library \ + LD_LIBRARY_PATH=$(BDIST)/unix-tk4.1:$(SITE_LDPATH) + +ENV_ITCL20_DIST = \ + TIX_LIBRARY=$(SDIST)/library \ + TCL_LIBRARY=@ITCL20_SRC_DIR@/tcl7.4/library \ + TK_LIBRARY=@ITCL20_SRC_DIR@/tk4.0/library \ + ITCL_LIBRARY=@ITCL20_SRC_DIR@/itcl/library \ + ITK_LIBRARY=@ITCL20_SRC_DIR@/itk/library \ + IWIDGETS_LIBRARY=@ITCL20_SRC_DIR@/iwidgets2.0.0 \ + LD_LIBRARY_PATH=$(SITE_LDPATH) + +ENV_ITCL21_DIST = \ + TIX_LIBRARY=$(SDIST)/library \ + TCL_LIBRARY=@ITCL21_SRC_DIR@/tcl7.5/library \ + TK_LIBRARY=@ITCL21_SRC_DIR@/tk4.1/library \ + ITCL_LIBRARY=@ITCL21_SRC_DIR@/itcl/library \ + ITK_LIBRARY=@ITCL21_SRC_DIR@/itk/library \ + IWIDGETS_LIBRARY=@ITCL21_SRC_DIR@/iwidgets2.1.0 \ + LD_LIBRARY_PATH=$(BDIST)/unix-itcl2.1:$(SITE_LDPATH) + +dist_tk40: + @echo + @echo ======================== tk40_dist + @echo + -$(ENV_TK40_DIST) ldd $(BDIST)/unix-tk4.0/tixwish + $(ENV_TK40_DIST) $(BDIST)/unix-tk4.0/tixwish Driver.tcl $(SUBSETS) + +dist_tk41: + @echo + @echo ======================== tk41_dist + @echo + -$(ENV_TK41_DIST) ldd $(BDIST)/unix-tk4.1/tixwish + $(ENV_TK41_DIST) $(BDIST)/unix-tk4.1/tixwish Driver.tcl $(SUBSETS) + +dist_itcl20: + @echo + @echo ======================== itcl20_dist + @echo + -$(ENV_ITCL20_DIST) ldd $(BDIST)/unix-itcl2.0/itixwish + $(ENV_ITCL20_DIST) $(BDIST)/unix-itcl2.0/itixwish Driver.tcl $(SUBSETS) + +dist_itcl21: + @echo + @echo ======================== itcl21_dist + @echo + -$(ENV_ITCL21_DIST) ldd $(BDIST)/unix-itcl2.1/itixwish + $(ENV_ITCL21_DIST) $(BDIST)/unix-itcl2.1/itixwish Driver.tcl $(SUBSETS) diff --git a/tix/tests/README b/tix/tests/README new file mode 100644 index 00000000000..13deba5f2ae --- /dev/null +++ b/tix/tests/README @@ -0,0 +1,58 @@ + Tix Test Suite + -------------- +COPYRIGHT + + Copyright (c) 1996, Expert Interface Technologies + + See the file "license.terms" for information on usage and + redistribution of this file, and for a DISCLAIMER OF ALL + WARRANTIES. + +EXECUTING TEST SUITES + +UNIX -- + + 1) cd to the test/ subdirectory. + + 2) To execute all of the test suite for all compilation targets, run: + + make all + + 3) To execute all of the test suites for a single compilation + target, run: + + make unix-tk4.0 + or make unix-itcl2.0 + or make unix-itcl2.1 + or make unix-tk4.1 + + 4) To execute a specific test only, you must invoke the apropriate + executable explicitly: + + ../unix-tk4.0/tixwish Driver.tcl general/select.tcl + + executes the test file general/select.tcl for the unix-tk4.0 + compilation target. + + ../unix-tk4.0/tixwish Driver.tcl general + + executes all the test files in the general/ subdirectory for the + unix-tk4.0 compilation target. + +WINDOWS -- + + 1) Open the DOS command window. + + 2) cd to the test/ subdirectory in the Tix source tree. + + 3) Run the following line in the DOS window to execute all the tests. + + txwish41.exe Driver.tcl + + 4) To select a specific test, try + + txwish41.exe Driver.tcl general/select.tcl + txwish41.exe Driver.tcl general + + ... etc + diff --git a/tix/tests/Test.tcl b/tix/tests/Test.tcl new file mode 100755 index 00000000000..b2e605232ca --- /dev/null +++ b/tix/tests/Test.tcl @@ -0,0 +1,60 @@ +#! /bin/sh +# the next line restarts using tclsh \ +exec tclsh "$0" "$@" + +# Test.tcl -- +# +# This file executes the Tix test suite for the Unix platform. +# Don't execute this file directly. Read the README file in this +# directory first. +# +# Copyright (c) 1996, Expert Interface Technologies +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +set targets [lindex $argv 0] +set argvfiles [lrange $argv 1 end] + +set env(WAITTIME) 200 + +set genDirs { + general xpm hlist +} + +set env(TCL_LIBRARY) $env(TEST_TCL_LIBRARY) +set env(TK_LIBRARY) $env(TEST_TK_LIBRARY) +set env(ITCL_LIBRARY) $env(TEST_ITCL_LIBRARY) +set env(ITK_LIBRARY) $env(TEST_ITK_LIBRARY) +set BINSRC_DIR $env(TEST_BINSRC_DIR) + +catch { + unset env(TIX_DEBUG_INTERACTIVE) +} + +set load(bin) $BINSRC_DIR/../tk4.1/unix/wish +set tk40(bin) $BINSRC_DIR/unix-tk4.0/tixwish +set tk41(bin) $BINSRC_DIR/unix-tk4.1/tixwish +set tk42(bin) $BINSRC_DIR/unix-tk4.2/tixwish +set itcl20(bin) $BINSRC_DIR/unix-itcl2.0/itixwish +set itcl21(bin) $BINSRC_DIR/unix-itcl2.1/itixwish + +if ![info exists env(LD_LIBRARY_PATH)] { + set env(LD_LIBRARY_PATH) "" +} +if [info exists env(TEST_LDPATHS)] { + set env(LD_LIBRARY_PATH) $env(TEST_LDPATHS):$env(LD_LIBRARY_PATH) +} + +foreach t $targets { + upvar #0 $t target + + puts "Executing ---\n" + puts "env TCL_LIBRARY=$env(TCL_LIBRARY) TK_LIBRARY=$env(TK_LIBRARY) ITCL_LIBRARY=$env(ITCL_LIBRARY) ITK_LIBRARY=$env(ITK_LIBRARY) LD_LIBRARY_PATH=$env(LD_LIBRARY_PATH) TIX_LIBRARY=$env(TIX_LIBRARY) $target(bin)" + puts "" + + + puts "Testing target $t with executable $target(bin)" + eval exec $target(bin) Driver.tcl $argvfiles >@ stdout 2>@ stderr +} diff --git a/tix/tests/cleanup/cleanup.tcl b/tix/tests/cleanup/cleanup.tcl new file mode 100644 index 00000000000..b76f44d0289 --- /dev/null +++ b/tix/tests/cleanup/cleanup.tcl @@ -0,0 +1,28 @@ +# cleanup.tcl -- +# +# This program tests whether whether there is any garbage left +# after all the test files are executed. If so, either Tix has +# resource leak or the test suite doesn't clean up properly. +# +# Copyright (c) 1996, Expert Interface Technologies +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +proc About {} { + return "Testing resource leaks" +} + +proc Test {} { + global testConfig + + if {$testConfig(VERBOSE) >= 20} { + foreach image [image names] { + puts "Warning: \[resource leak\] image $image of type [image type $image]" + foreach option [$image configure] { + puts " $option" + } + } + } +} diff --git a/tix/tests/cleanup/files b/tix/tests/cleanup/files new file mode 100644 index 00000000000..4dae806d004 --- /dev/null +++ b/tix/tests/cleanup/files @@ -0,0 +1 @@ +cleanup.tcl
\ No newline at end of file diff --git a/tix/tests/files b/tix/tests/files new file mode 100644 index 00000000000..747a4781423 --- /dev/null +++ b/tix/tests/files @@ -0,0 +1,24 @@ +# List of tests to execute. +# Format: +# +# {<file/directory name> <Description> <List of conditions>} +# {<file/directory name> <Description> <List of conditions>} +# ... +# +# the conditions are AND'ed. Target is taken only if all conditions +# are true + +{general } +{xpm {i pixmap} } +{hlist {c tixHList} } +{load {c load} } +{tlist {c tixTList} } +{grid {c tixGrid} } +{itcl {c @scope} } + +# This following subdirectory tests whether there is any garbage left +# after all the test files are executed. If so, either Tix has +# resource leak or the test suite doesn't clean up properly. +# + +{cleanup } diff --git a/tix/tests/general/NoteBook.tcl b/tix/tests/general/NoteBook.tcl new file mode 100644 index 00000000000..c68a5301171 --- /dev/null +++ b/tix/tests/general/NoteBook.tcl @@ -0,0 +1,60 @@ +proc About {} { + return "Testing the notebook widgets" +} + +proc NoteBookPageConfig {w pages} { + foreach page $pages { + Assert {"x[$w pagecget $page -label]" == "x$page"} + Assert {"x[$w pageconfigure $page -label]" == "x-label {} {} {} $page"} + $w pageconfigure $page -label foo + Assert {"x[$w pagecget $page -label]" == "xfoo"} + update + } +} + +proc Test {} { + foreach class {tixListNoteBook tixNoteBook tixStackWindow} { + set w [$class .d] + pack $w + update + + set pages {1 2 3 4 5 6 1111111112221} + + foreach page $pages { + if {$class == "tixListNoteBook"} { + $w subwidget hlist add $page -itemtype imagetext \ + -image [tix getimage folder] -text $page + } + set p [$w add $page -label $page] + for {set x 1} {$x < 10} {incr x} { + button $p.$x -text $x + pack $p.$x -fill x + } + } + + foreach page $pages { + $w raise $page + Assert {"x[$w raised]" == "x$page"} + update + } + + Assert {[string compare $pages [$w pages]] == 0} + + # test the "hooking" of the notebook frame subwidget + # + # + if {$class == "tixNoteBook"} { + NoteBookPageConfig $w $pages + } + + foreach page $pages { + Assert {"x[$w pagecget $page -raisecmd]" == "x"} +# Assert {"x[$w pageconfigure $page -raisecmd]" == "x-raisecmd {} {} {} {}"} + $w pageconfigure $page -raisecmd "RaiseCmd $page" + Assert {"x[$w pagecget $page -raisecmd]" == "xRaiseCmd $page"} + update + } + + destroy $w + } +} diff --git a/tix/tests/general/api.tcl b/tix/tests/general/api.tcl new file mode 100644 index 00000000000..7dcf278944d --- /dev/null +++ b/tix/tests/general/api.tcl @@ -0,0 +1,254 @@ +# api.tcl -- +# +# Performs a comprehensive test on all the Tix widgets and +# commands. This test knows the types and arguments of many +# common Tix widget methods. It calls each widget method and +# ensure that it work as expected. +# +# +# Copyright (c) 1996, Expert Interface Technologies +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +set depd(init) "" +set info(init) "Initialization, find out all the widget classes" +set depd(wcreate) "init" +set info(wcreate) "Try to create each widget" +set depd(method) "init wcreate" +set info(method) "Try to call each public method of all widgets" +set depd(config-state) "init wcreate method" +set info(config-state) "Configuring -state of widgets" + +proc APITest:init {} { + global widCmd cmdNames auto_index testConfig + + TestBlock api-1.1 {Find out all the widget classes} { + # (1) Stores all the Tix commands in the associative array + # cmdNames + # + foreach cmd [info commands tix*] { + if [regexp : $cmd] { + continue + } + set cmdNames($cmd) "" + } + + foreach name [array names auto_index "tix*:AutoLoad"] { + if [regsub {:AutoLoad} $name "" cmd] { + set cmdNames($cmd) "" + } + } + + # (3). Don't want to mess with the console routines + # + foreach name [array names cmdNames] { + if [string match tixCon* $name] { + catch { + unset cmdNames($name) + } + } + } + + # (2) Find out the names of the widget creation commands + # + foreach cmd [lsort [array names cmdNames]] { + if [info exists $cmd\(superClass\)] { + if {[set $cmd\(superClass\)] == ""} { + continue + } + } + switch -regexp -- $cmd { + {(DoWhenIdle)|(:)} { + continue + } + } + + if [info exists err] { + unset err + } + + catch { + auto_load $cmd + } + catch { + if {[uplevel #0 set $cmd\(isWidget\)] == 1} { + if {$testConfig(VERBOSE) > 20} { + puts "Found widget class: $cmd" + } + set widCmd($cmd) "" + } + } + } + } +} + +proc APITest:wcreate {} { + global widCmd testConfig + + TestBlock api-2 {Find out all the widget classes} { + foreach cls [lsort [array names widCmd]] { + if {[uplevel #0 set $cls\(virtual\)] == 1} { + # This is a virtual base class. Skip it. + # + continue + } + + TestBlock api-2.1-$cls "Create widget of class: $cls" { + $cls .c + if ![tixStrEq [winfo toplevel .c] .c] { + pack .c -expand yes -fill both + } + update + } + + TestBlock api-2.2-$cls "Widget Deletion" { + catch { + destroy .c + } + + frame .c + update idletasks + global .c + if {[info exists .c] && [array names .c] != "context"} { + catch { + parray .c + } + catch { + puts [set .c] + } + error "widget record has not been deleted properly" + } + } + catch { + destroy .c + } + } + } +} + +proc APITest:method {} { + global widCmd testConfig + + TestBlock api-3 {Call all the methods of a widget class} { + + foreach cls [lsort [array names widCmd]] { + if {[uplevel #0 set $cls\(virtual\)] == 1} { + continue + } + + TestBlock api-3.1-$cls "Widget class: $cls" { + $cls .c + + upvar #0 $cls classRec + foreach method [lsort $classRec(methods)] { + TestBlock api-3.1.1 "method: $method" { + catch { + .c $method + } + } + } + } + catch { + destroy .c + } + } + } +} + +proc APITest:config-state {} { + global widCmd testConfig + + TestBlock api-4 {Call the config-state method} { + + foreach cls [lsort [array names widCmd]] { + if {[uplevel #0 set $cls\(virtual\)] == 1} { + continue + } + + $cls .c + catch { + pack .c + } + if [catch {.c cget -state}] { + destroy .c + continue + } + + if [tixStrEq $cls tixBalloon] { + destroy .c + continue + } + + TestBlock api-4.1-$cls "Class: $cls" { + .c config -state disabled + Assert {[tixStrEq [.c cget -state] "disabled"]} + update + Assert {[tixStrEq [.c cget -state] "disabled"]} + + .c config -state normal + Assert {[tixStrEq [.c cget -state] "normal"]} + update + Assert {[tixStrEq [.c cget -state] "normal"]} + + + .c config -state disabled + Assert {[tixStrEq [.c cget -state] "disabled"]} + .c config -state normal + Assert {[tixStrEq [.c cget -state] "normal"]} + + } + catch { + destroy .c; update + } + } + } +} + +proc APITest {t {level 0}} { + global depd tested info + + if {$level > 300} { + error "possibly circular dependency" + } + + set tested(none) 1 + + if [info exist tested($t)] { + return + } + foreach dep $depd($t) { + if {![info exists tested($dep)]} { + APITest $dep [expr $level + 1] + } + } + + if {$t == "all"} { + set tested($t) 1 + return + } else { + update + eval APITest:$t + set tested($t) 1 + } +} + +proc About {} { + return "Tix API Testing Suite" +} + +proc Test {} { + global depd env + + if [info exists env(APT_SUBSET)] { + set tests $env(APT_SUBSET) + } else { + set tests [array names depd] + } + + foreach test $tests { + APITest $test + } +} + diff --git a/tix/tests/general/cmderror.tcl b/tix/tests/general/cmderror.tcl new file mode 100644 index 00000000000..1ff2d4dd132 --- /dev/null +++ b/tix/tests/general/cmderror.tcl @@ -0,0 +1,49 @@ +# cmderror.tcl -- +# +# This program tests whether command handler errors are processed +# properly by the Tix toolkit. +# +# Copyright (c) 1996, Expert Interface Technologies +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +proc About {} { + return "Testing command handler errors are processed properly" +} + +proc Test {} { + global cmdHandlerCalled + + if {![string compare [info command tixCmdErrorHandler] ""]} { + if ![auto_load tixCmdErrorHandler] { + TestAbort "toolkit error: procedure \"tixCmdErrorHandler\" not implemented" + } + } + rename tixCmdErrorHandler _default_tixCmdErrorHandler + proc tixCmdErrorHandler {msg} { + global cmdHandlerCalled + set cmdHandlerCalled 1 + } + + # We cause an error to occur in the -command handler of the combobox + # widget. Such an error shouldn't cause the operation to fail. + # See the programmer's documentation of tixCmdErrorHandler for details. + # + catch { + tixComboBox .c -command CmdNotFound + .c invoke + set cmdNotFailed 1 + } + Assert {[info exists cmdNotFailed]} + Assert {[info exists cmdHandlerCalled]} + + # Clean up + # + destroy .c + rename tixCmdErrorHandler "" + rename _default_tixCmdErrorHandler tixCmdErrorHandler + unset cmdHandlerCalled + +} diff --git a/tix/tests/general/combobox.tcl b/tix/tests/general/combobox.tcl new file mode 100644 index 00000000000..870fadb713f --- /dev/null +++ b/tix/tests/general/combobox.tcl @@ -0,0 +1,107 @@ +# combobox.tcl -- +# +# Tests the ComboBox widget. +# +# Copyright (c) 1996, Expert Interface Technologies +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +proc About {} { + return "Testing the ComboBox widget." +} + +proc cbTest_Command {args} { + global cbTest_selected + + set cbTest_selected [tixEvent value] +} + +proc cbTest_ListCmd {w} { + global counter + + incr counter + + $w subwidget listbox delete 0 end + $w subwidget listbox insert end 0 + $w subwidget listbox insert end 1 + $w subwidget listbox insert end 2 +} + + +proc Test {} { + global cbTest_selected + + for {set dropdown 1} {$dropdown >= 0} {incr dropdown -1} { + + TestBlock combo-1.1 {Config -value} { + set w [tixComboBox .c -command cbTest_Command -dropdown $dropdown \ + -editable true] + pack $w + update + set val "Testing some value .." + $w config -value $val + Assert {[tixStrEq "$cbTest_selected" $val]} + } + + TestBlock combo-1.2 {selection from listbox} { + $w subwidget listbox insert end "entry 0" + $w subwidget listbox insert end "entry 1" + $w subwidget listbox insert end "entry 2" + + for {set x 0} {$x <= 2} {incr x} { + Click [$w subwidget arrow] + update + + if $dropdown { + ClickListboxEntry [$w subwidget listbox] $x single + } else { + ClickListboxEntry [$w subwidget listbox] $x single + ClickListboxEntry [$w subwidget listbox] $x double + } + update + + Assert {[tixStrEq "$cbTest_selected" "entry $x"]} + } + } + + TestBlock combo-1.3 {invokation by keyboard} { + set val "Testing by key with \\ slashes" + KeyboardString [$w subwidget entry] $val + KeyboardEvent [$w subwidget entry] <Return> + update + + Assert {[tixStrEq "$cbTest_selected" "$val"]} + } + + catch { + destroy $w + } + } + + TestBlock combo-2.1 {-listcmd of ComboBox} { + global counter + set counter 0 + tixComboBox .c -listcmd "cbTest_ListCmd .c" + pack .c -expand yes -fill both + update + + Click [.c subwidget arrow] + update + Assert {$counter == 1} + Click [.c subwidget arrow] + update + + Click [.c subwidget arrow] + update + Click [.c subwidget arrow] + update + Assert {$counter == 2} + + + Assert {[.c subwidget listbox get 0] == "0"} + Assert {[.c subwidget listbox get 1] == "1"} + Assert {[.c subwidget listbox get 2] == "2"} + } +} diff --git a/tix/tests/general/dirbox.tcl b/tix/tests/general/dirbox.tcl new file mode 100644 index 00000000000..c672cd069a0 --- /dev/null +++ b/tix/tests/general/dirbox.tcl @@ -0,0 +1,281 @@ +# dirbox.tcl -- +# +# Tests the DirSelectBox and DirSelectDialog widgets. +# +# Copyright (c) 1996, Expert Interface Technologies +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +proc About {} { + return "Testing the DirSelectBox and DirSelectDialog widgets." +} + +# Try to configure the directory of a widget and see if it satisfy all +# the requirements: +# +# 1: Should return error for non-existant directory, preserving +# the old directory +# +# 2: When given a non-normalized path, it should normalize it. +# +proc TestConfigDirectory {class spec pack} { + global errorInfo + + set w .w + + if [winfo exists $w] { + destroy $w + } + + TestBlock config-dir-1.1 "Simple creating of $class" { + # Creation without the spec. The default value should be normalized + # + + # The default value should always be an absolute path + # + $class .w + set value [$w cget $spec] + Assert {[tixFSIsNorm_os $value]} 0 cont + } + catch { + destroy .w + } + + TestBlock config-dir-1.2 "Creation with arbitrary (perhaps invalid) path" { + foreach item [GetCases_FsNormDir] { + if [info exists errorInfo] { + set errorInfo "" + } + + set text [lindex $item 0] + set want [lindex $item 1] + set wanterr [lindex $item 2] + + set err [catch { + set w [$class .w $spec $text] + set got [$w cget -value] + }] + Assert {$err == $wanterr} + if {!$err} { + set want [tixFSDisplayName $want] + Assert {[tixStrEq $want $got]} + } + + catch { + destroy .w + } + } + } + + catch { + destroy .w + } + + TestBlock config-dir-1.2 "Config with arbitrary (perhaps invalid) path" { + set w [$class .w] + + foreach item [GetCases_FsNormDir] { + if [info exists errorInfo] { + set errorInfo "" + } + + set text [lindex $item 0] + set want [lindex $item 1] + set wanterr [lindex $item 2] + + set err [catch { + $w config $spec $text + set got [$w cget -value] + }] + Assert {$err == $wanterr} + + if $err { + # Should hold the previous -value + # + set value [$w cget $spec] + Assert {[tixFSIsNorm_os $value]} 0 cont + } else { + set value [$w cget $spec] + Assert {[tixFSIsNorm_os $value]} 0 cont + + set want [tixFSDisplayName $want] + Assert {[tixStrEq $want $got]} + } + + if $pack { + pack $w -expand yes -fill both -padx 10 -pady 10 + update idletasks + } + } + } + + catch { + destroy $w + } +} + +proc TestRand {max} { + global testRandSeed + + if ![info exists testRandSeed] { + set testRandSeed [expr [lindex [time {cd [pwd]}] 0] * 47 + 147] + } + + set x [expr ($testRandSeed + 47) * [lindex [time {cd [pwd]}] 0]] + set x [expr $x + 7 * $max] + set testRandSeed [expr ($x % $max) + $max] + + return [expr $testRandSeed % $max] +} + +# TestHListWildClick -- +# +# Randomly click around an hlist widget +# +# Args: +# hlist:widget The HList widget. +# mode: Either "single" or "double", indicating which type +# of mouse click is desired. +# cmd: Command to call after each click. +# +proc TestHListWildClick {hlist mode cmd} { + # The percentage chance that we sould traverse to a child node + # + set chance 40 + + for {set x 0} {$x < 10} {incr x} { + set node [$hlist info children ""] + if [tixStrEq $node ""] { + return + } + + while 1 { + set ran [TestRand 100] + if {$ran >= $chance} { + break + } + set children [$hlist info children $node] + if [tixStrEq $children ""] { + break + } + set node [lindex $children [expr $ran % [llength $children]]] + } + + TestBlock wild-click-1.1 "clicking \"$node\" of HList" { + if {![regexp -nocase alex [$hlist info data $node]]} { + # + # dirty fix: "alex" may be an AFS mounted file. Reading this + # directory may start an FTP session, which may be slow like + # hell + # + ClickHListEntry $hlist $node $mode + eval $cmd [list $node] + } + } + } +} + + +proc DirboxTest_Cmd {args} { + global dirboxTest_selected + + set dirboxTest_selected [tixEvent value] +} + +proc DirboxTest_Compare {isDirBox w h node} { + global dirboxTest_selected + + set selFile [$h info data $node] + + Assert {[tixStrEq "$dirboxTest_selected" "$selFile"]} + set dirboxTest_selected "" + + if {$isDirBox} { + set entry [$w subwidget dircbx subwidget combo subwidget entry] + set entText [$entry get] + Assert {[tixStrEq "$entText" "$selFile"]} + } +} + +proc Test {} { + global dirboxTest_selected + + #------------------------------------------------------------ + # (1) DirList + #------------------------------------------------------------ + + TestBlock dirbox-1.1 {Generic testing of tixDirList} { + TestConfigDirectory tixDirList -value 1 + } + + TestBlock dirbox-1.2 {Wild click on the hlist subwidget} { + set dirboxTest_selected "" + set w [tixDirList .c -command DirboxTest_Cmd] + set h [$w subwidget hlist] + pack $w -expand yes -fill both + TestHListWildClick $h double "DirboxTest_Compare 0 $w $h" + } + catch { + destroy $w + } + + #------------------------------------------------------------ + # (2) DirTree + #------------------------------------------------------------ + + TestBlock dirbox-2.1 {Generic testing of tixDirTree} { +# TestConfigDirectory tixDirTree -value 1 + } + + TestBlock dirbox-2.2 {Wild click on the hlist subwidget} { + set dirboxTest_selected "" + set w [tixDirTree .c -command DirboxTest_Cmd] + set h [$w subwidget hlist] + pack $w -expand yes -fill both +# TestHListWildClick $h double "DirboxTest_Compare 0 $w $h" + } + catch { + destroy $w + } + + #------------------------------------------------------------ + # (3) DirBox + #------------------------------------------------------------ + + TestBlock dirbox-3.1 {Generic testing of tixDirSelectBox} { +# TestConfigDirectory tixDirSelectBox -value 1 + } + + TestBlock dirbox-3.2 {Wild click on the hlist subwidget} { + set dirboxTest_selected "" + set w [tixDirSelectBox .c -command DirboxTest_Cmd] + set h [$w subwidget dirlist subwidget hlist] + pack $w -expand yes -fill both +# TestHListWildClick $h double "DirboxTest_Compare 0 $w $h" + } + catch { + destroy $w + } + + TestBlock dirbox-4.1 {-disablecallback option} { + global dirbox_called + tixDirList .c -command dirbox_callback + pack .c + set dirbox_called 0 + .c config -disablecallback 1 + .c config -value [pwd] + .c config -disablecallback 0 + Assert {$dirbox_called == 0} + } + catch { + destroy .c + } +} + +proc dirbox_callback {args} { + global dirbox_called + set dirbox_called 1 +} + diff --git a/tix/tests/general/draw.tcl b/tix/tests/general/draw.tcl new file mode 100644 index 00000000000..6206f007410 --- /dev/null +++ b/tix/tests/general/draw.tcl @@ -0,0 +1,22 @@ +# draw.tcl -- +# +# Test the drawing functions in Tix. +# +# Copyright (c) 1996, Expert Interface Technologies +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +proc About {} { + return "Test the drawing functions in Tix." +} + +proc Test {} { + TestBlock draw-1.1 {tixTmpLine} { + tixTmpLine 0 50 300 50 + tixTmpLine 0 50 300 50 + tixTmpLine 0 50 300 50 . + tixTmpLine 0 50 300 50 . + } +} diff --git a/tix/tests/general/event0.tcl b/tix/tests/general/event0.tcl new file mode 100644 index 00000000000..fd46b6edba7 --- /dev/null +++ b/tix/tests/general/event0.tcl @@ -0,0 +1,100 @@ +proc About {} { + return "Testing the event emulation routines in the test suite" +} + +proc TestEntry_Invoke {w} { + global testEntry_Invoked testEntry_value1 + + set testEntry_Invoked 1 + set testEntry_value1 [$w get] +} + +proc Test {} { + global foo + set foo 0 + + TestBlock event0-1.1 {Typing return in an entry widget} { + global testEntry_Invoked testEntry_value0 testEntry_value1 + + set testEntry_Invoked 0 + entry .e -textvariable testEntry_value0 + set testEntry_value0 "Entering some text ..." + bind .e <Return> "TestEntry_Invoke .e" + pack .e + update + + KeyboardEvent .e <Return> + update + Assert {$testEntry_Invoked == 1} + Assert {$testEntry_value0 == $testEntry_value1} + } + + TestBlock event0-1.2 {Typing characters in an entry widget} { + set testEntry_value0 "" + set val "Typing the keyboard ..." + + focus .e + .e delete 0 end + update + KeyboardString .e $val + update + Assert {[tixStrEq "$testEntry_value0" "$val"]} + } + + TestBlock event0-1.3 {Typing characters and slashes in an entry widget} { + set testEntry_value0 "" + set val "Typing the \\ keyboard ..." + + focus .e + .e delete 0 end + KeyboardString .e $val + update + Assert {[tixStrEq "$testEntry_value0" "$val"]} + + destroy .e + } + + TestBlock event0-1.4 {Testing ClickListboxEntry} { + listbox .l -selectmode single + .l insert end "index 0" + .l insert end "index 1" + .l insert end "index 2" + + pack .l; update + + for {set x 0} {$x <= 2} {incr x} { + ClickListboxEntry .l $x single + update + Assert {[.l index active] == $x} + Assert {[.l curselection] == $x} + } + + destroy .l + update + } + + TestBlock event0-1.5 {Clicking a button} { + button .b -command "set foo 1" + pack .b; update + + Click .b + Assert {$foo == 1} + } + + TestBlock event0-1.6 {Drag and selecting a combobox} { + tixComboBox .c + .c insert end 10 + .c insert end 10 + .c insert end 10 + .c insert end 10 + .c insert end 10 + pack .c; update + + HoldDown [.c subwidget arrow] + Drag [.c subwidget listbox] 10 10 + Release [.c subwidget listbox] 10 10 + Release [.c subwidget arrow] -30 30 + + Assert {[.c cget -value] == "10"} + } +} diff --git a/tix/tests/general/filebox.tcl b/tix/tests/general/filebox.tcl new file mode 100644 index 00000000000..4ded2be0854 --- /dev/null +++ b/tix/tests/general/filebox.tcl @@ -0,0 +1,133 @@ +# filebox.tcl -- +# +# Tests the File selection box and dialog widget. +# +# Copyright (c) 1996, Expert Interface Technologies +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +proc About {} { + return "Testing the (Ex)FileSelectBox and (Ex)FileSelectDialog widgets." +} + +proc FdTest_GetFile {args} { + global fdTest_selected + + set fdTest_selected [tixEvent value] +} + +proc Test {} { + global fdTest_fullPath + + if [tixStrEq [tix platform] "unix"] { + set fdTest_fullPath /etc/passwd + } else { + set fdTest_fullPath C:\\Windows\\System.ini + } + + Test_FileSelectBox + Test_FileSelectDialog + + Test_ExFileSelectBox + Test_ExFileSelectDialog +} + +proc Test_FileSelectBox {} { + global fdTest_selected fdTest_fullPath + + TestBlock filebox-1.1 {FileSelectBox} { + set w [tixFileSelectBox .f -command FdTest_GetFile] + pack $w -expand yes -fill both + update + + InvokeComboBoxByKey [$w subwidget selection] "$fdTest_fullPath" + Assert {[tixStrEq $fdTest_selected "$fdTest_fullPath"]} + } + catch { + destroy $w + } +} + +proc Test_FileSelectDialog {} { + global fdTest_selected fdTest_fullPath + + TestBlock filebox-2.1 {FileSelectDialog} { + set w [tixFileSelectDialog .f -command FdTest_GetFile] + $w popup + update + + InvokeComboBoxByKey [$w subwidget fsbox subwidget selection] \ + "$fdTest_fullPath" + Assert {[tixStrEq $fdTest_selected "$fdTest_fullPath"]} + } + catch { + destroy $w + } +} + +proc Test_ExFileSelectBox {} { + global fdTest_selected fdTest_fullPath + + TestBlock filebox-3.1 {ExFileSelectBox} { + set w [tixExFileSelectBox .f -command FdTest_GetFile] + pack $w -expand yes -fill both + update + + $w subwidget file config -selection "$fdTest_fullPath" \ + -value "$fdTest_fullPath" + Assert {[tixStrEq $fdTest_selected "$fdTest_fullPath"]} + } + + TestBlock filebox-3.2 {Keyboard input in ExFileSelectBox entry subwidget} { + set dirCbx [$w subwidget dir] + set fileCbx [$w subwidget file] + set okBtn [$w subwidget ok] + + foreach file {Foo bar "Foo Bar"} { + set fdTest_selected "" + + InvokeComboBoxByKey $fileCbx $file + set fullPath [tixFSJoin [$dirCbx cget -value] $file] + update + + Assert {[tixStrEq "$fdTest_selected" "$fullPath"]} + } + } + + TestBlock filebox-3.3 {Keyboard and then press OK} { + foreach file {bar "Foo Bar"} { + set fdTest_selected "" + + SetComboBoxByKey $fileCbx $file + Click $okBtn + set fullPath [tixFSJoin [$dirCbx cget -value] $file] + update + + Assert {[tixStrEq "$fdTest_selected" "$fullPath"]} + } + } + + catch { + destroy $w + } +} + +proc Test_ExFileSelectDialog {} { + global fdTest_selected fdTest_fullPath + + TestBlock filebox-4.1 {ExFileSelectDialog} { + set w [tixExFileSelectDialog .f -command FdTest_GetFile] + $w popup + update + + InvokeComboBoxByKey [$w subwidget fsbox subwidget file] \ + $fdTest_fullPath + Assert {[tixStrEq $fdTest_selected "$fdTest_fullPath"]} + } + + catch { + destroy $w + } +} diff --git a/tix/tests/general/files b/tix/tests/general/files new file mode 100644 index 00000000000..21acdc020b3 --- /dev/null +++ b/tix/tests/general/files @@ -0,0 +1,20 @@ +testtmpl.tcl +api.tcl +minterp.tcl +options.tcl +labentry.tcl +event0.tcl +fs.tcl +oop.tcl +optmenu.tcl +select.tcl +slistbox.tcl +var1.tcl +NoteBook.tcl +mwm.tcl +cmderror.tcl +dirbox.tcl +filebox.tcl +combobox.tcl +samples.tcl +draw.tcl diff --git a/tix/tests/general/fs.tcl b/tix/tests/general/fs.tcl new file mode 100644 index 00000000000..d2f1e86ca62 --- /dev/null +++ b/tix/tests/general/fs.tcl @@ -0,0 +1,236 @@ +# fs.tcl -- +# +# Test the portable file handling ("FS") routines. +# +# Copyright (c) 1996, Expert Interface Technologies +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +proc About {} { + return "Testing portable file handling routines" +} + +proc Test {} { + global tixPriv errorInfo + + TestBlock fs-1.1 {tixFSPath command} { + if {$tixPriv(test:platform) == "windows"} { + # PATHNAME expected VPATH result + #------------------------------------------------------- + set list [list \ + [list :px:\\C: C:\\ 0] \ + [list :px:\\c: "" 1] \ + ] + regsub -all :px: $list $tixPriv(WinPrefix) list + + foreach item "$list" { + set vpath [lindex $item 0] + set want [lindex $item 1] + set experr [lindex $item 2] + + + TestBlock fs-1.1.1 "tixFSPath $vpath" { + set err [catch { + set got [tixFSPath $vpath] + }] + + if $experr { + Assert {$err == $experr} + } else { + Assert {[tixStrEq $want $got]} + } + } + } + } + } + + TestBlock fs-1.2 {tixFSIsNorm command} { + if {$tixPriv(test:platform) == "unix"} { + + # PATHNAME to TEST expected result + #------------------------------------------------------- + set list { + {/home/ioi 1} + {/foo.bar 1} + {/.../foo 1} + {/.../foo/bar/... 1} + {/.../.foo/bar/... 1} + {/.../.f./bar/... 1} + {/.../.f./bar/... 1} + {/..a/... 1} + {"/. / " 1} + {//a 0} + {/a/b/ 0} + {/a/b// 0} + {/a/b/. 0} + {a/b 0} + {a/b/. 0} + {/./b 0} + {/../b 0} + {/../../b 0} + {/./a/../b/.. 0} + {~ioi 0} + {/~ioi 1} + {/ 1} + } + } else { + set list { + {C:/ 0} + {foo 0} + {c: 0} + {C: 1} + {C:\\Windows 1} + {C:\\ 0} + {C:\\..\\Windows 0} + {C:\\...\\Windows 1} + {C:\\.../Windows 1} + {C:\\.\\Windows 0} + {.. 0} + {..\\.. 0} + {..\\ 0} + {. 0} + {.\\. 0} + {.\\ 0} + {C:\\. 0} + {C:Windows 0} + {C:\\Windows\\App 1} + {"C:\\My Programs\\~App" 1} + } + } + + foreach item $list { + set text [lindex $item 0] + set want [lindex $item 1] + + + TestBlock fs-1.2.1 "tixFSIsNorm $text" { + Assert {[tixFSIsNorm $text] == $want} + } + } + } + + TestBlock fs-1.3 {tixFSNormDir command} { + foreach item [GetCases_FsNormDir] { + set text [lindex $item 0] + set want [lindex $item 1] + set wanterr [lindex $item 2] + + if !$wanterr { + # Check test case error + Assert {[tixFSIsNorm $want]} + } + + TestBlock fs-1.3.1 "tixFSNormDir $text" { + set err [catch { + set got [tixFSNormDir $text] + }] + + Assert {$err == $wanterr} + if {!$err} { + Assert {[tixStrEq $want $got]} + } + } + } + } + + TestBlock fs-1.4 {tixFSNorm command} { + set list [GetCases_FSNorm] + + set appPWD [pwd] + foreach item $list { + set text [lindex $item 0] + set context [lindex $item 1] + set want [lindex $item 2] + + TestBlock fs-1.4.1 "tixFSNorm $context $text" { + set lst [tixFSNorm $context $text] + set dir [lindex $lst 1] + Assert {[tixStrEq $want $dir]} + Assert {[tixStrEq [pwd] $appPWD]} + } + } + } + + TestBlock fs-1.5 {tilde handling} { + if {$tixPriv(test:platform) == "unix"} { + set who "nobody" + if {[string comp $who "nobody"] == 0} { + catch {set who [exec whoami]} + } + if {[string comp $who "nobody"] == 0} { + catch {set who [exec logname]} + } + set home / + catch { + set home [glob ~$who] + } + set list { + {~$who {$home $home "" ""}} + {~ {$home $home "" ""}} + {~/*.* {$home/*.* $home "" "*.*"}} + {"~/*.* *.tcl" {"$home/*.* *.tcl" $home "" "*.* *.tcl"}} + } + + foreach item $list { + set item [subst $item] + set text [lindex $item 0] + set want [lindex $item 1] + + TestBlock fs-1.5.1 "tixFSNorm \[pwd\] $text" { + set list [tixFSNorm [pwd] $text] + + Assert { + [tixStrEq [lindex $list 0] [lindex $want 0]] && + [tixStrEq [lindex $list 1] [lindex $want 1]] && + [tixStrEq [lindex $list 2] [lindex $want 2]] && + [tixStrEq [lindex $list 3] [lindex $want 3]] + } + } + } + } + } + + TestBlock fs-1.6 {tixFSVPath} { + if {$tixPriv(test:platform) == "unix"} { + + # PATHNAME to TEST expected Causes error for + # result tixFSVPath? + #---------------------------------------------------------------- + set list { + {. "" 1} + {foo "" 1} + {./ "" 1} + } + } else { + set list { + {. "" 1} + } + regsub -all ^:px: $list $tixPriv(WinPrefix) list + } + + # (ToDo): write the test + # + } + + TestBlock fs-2.1 {obsolete tests} { + # Some obsolete test. Should be taken out. + # + if {$tixPriv(test:platform) == "unix"} { + set home [glob ~] + if {$home == "/"} { + set homeprefix {} + } else { + set homeprefix $home + } + + # it shouldn't do itemname substitution + # + Assert {[tixFileIntName *] == "*"} + Assert {[tixFileIntName ~/*] == "$homeprefix/*"} + + Assert {[tixFileIntName /home/ioi/../foo/bar/..] == "/home/foo"} + } + } +} diff --git a/tix/tests/general/labentry.tcl b/tix/tests/general/labentry.tcl new file mode 100644 index 00000000000..714fda12b75 --- /dev/null +++ b/tix/tests/general/labentry.tcl @@ -0,0 +1,52 @@ +# labentry.tcl -- +# +# Tests the TixLabelEntry widget. +# +# Copyright (c) 1996, Expert Interface Technologies +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +proc About {} { + return "Testing the TixLabelEntry widget" +} + +proc Test {} { + TestBlock labent-1.1 {LabelEntry focus management} { + set t [toplevel .t] + + set w [tixLabelEntry .t.c -label "Stuff: "] + pack $w -padx 20 -pady 10 + tixLabelEntry .t.d -label "Stuff: " + pack .t.d -padx 20 -pady 10 + focus $w + update + + set px [winfo pointerx $t] + set py [winfo pointery $t] + set W [winfo width $t] + set H [winfo height $t] + + if {$W < 100} { + set W 100 + } + if {$H < 100} { + set H 100 + } + + set mx [expr $px - $W / 2] + set my [expr $py - $H / 2] + + # We must move the window under the cursor in order to test + # the current focus + # + wm geometry $t $W\x$H+$mx+$my + raise $t + update + + Assert {[focus -lastfor $t] == [$w subwidget entry]} + + destroy $t + } +} diff --git a/tix/tests/general/minterp.tcl b/tix/tests/general/minterp.tcl new file mode 100644 index 00000000000..270f73f032b --- /dev/null +++ b/tix/tests/general/minterp.tcl @@ -0,0 +1,60 @@ +# minterp.tcl +# +# Tests Tix running under multiple interpreters. +# +# Copyright (c) 1996, Expert Interface Technologies +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +proc About {} { + return "Tests Tix running under multiple interpreters." +} + +proc Test {} { + global tix tcl_version + if ![string comp [info commands interp] ""] { + # Does not support multiple interpreters. + return + } + + if {[lsearch [package names] Itcl] != -1} { + # + # multiple interpreters currently core dumps under itcl2.1 + # +# return + } + + TestBlock minterp-1.1 {multiple interpreters} { + for {set x 0} {$x < 5} {incr x} { + global testConfig + interp create a + interp eval a "set dynlib [list $testConfig(dynlib)]" + if {[info exists tix(et)] && $tix(et) == 1} { + interp eval a { + catch {load "" Tk} + catch {load "" ITcl} + catch {load "" ITk} + catch {load "" Tclsam} + catch {load "" Tksam} + catch {load "" Tixsam} + } + } else { + interp eval a { + load "" Tk + load $dynlib Tix + } + } + interp eval a { + tixControl .d -label Test + tixComboBox .e -label Test + tixDirList .l + pack .l -expand yes -fill both + pack .d .e -expand yes -fill both + update + } + interp delete a + } + } +} diff --git a/tix/tests/general/mwm.tcl b/tix/tests/general/mwm.tcl new file mode 100644 index 00000000000..5419351eaee --- /dev/null +++ b/tix/tests/general/mwm.tcl @@ -0,0 +1,46 @@ +# mwm.tcl -- +# +# Test tixMwm command. +# +# Copyright (c) 1996, Expert Interface Technologies +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +proc About {} { + return "Testing tixMwm command" +} + +proc Test {} { + if ![string compare [info command tixMwm] ""] { + puts "(OK) The tixMwm command is not available." + return + } + if ![tixMwm ismwmrunning .] { + puts "(OK) Mwm is not running on this display." + return + } + + toplevel .d + toplevel .e + + test {tixMwm protocol .d add MY_PRINT_HELLO {"Print Hello" _H Ctrl<Key>H}} + wm protocol .d MY_PRINT_HELLO {puts Hello} + + test {tixMwm protocol .e add MY_PRINT_HELLO {"Print Hello" _H Ctrl<Key>H}} + wm protocol .e MY_PRINT_HELLO {puts Hello} + + test {destroy .d} + + test {tixMwm protocol .e add MY_PRINT_HELLO {"Print Hello" _H Ctrl<Key>H}} + wm protocol .e MY_PRINT_HELLO {puts Hello} + + test {tixMwm protocol . delete MY_PRINT_HELLO} + wm protocol . MY_PRINT_HELLO {} + + test {tixMwm protocol .e add MY_PRINT_HELLO {"Print Hello" _H Ctrl<Key>H}} + wm protocol .e MY_PRINT_HELLO {puts Hello} + + test {destroy .e} +} diff --git a/tix/tests/general/oop.tcl b/tix/tests/general/oop.tcl new file mode 100644 index 00000000000..340e4cb91bf --- /dev/null +++ b/tix/tests/general/oop.tcl @@ -0,0 +1,11 @@ +proc About {} { + return "Testing OOP features" +} + +proc Test {} { + test {tix} {arg} + test {tixWidgetClass} {arg} + test {tixClass} {arg} + test {tixNoteBook} {arg} + test {tixAppContext} {arg} +} diff --git a/tix/tests/general/options.tcl b/tix/tests/general/options.tcl new file mode 100644 index 00000000000..acb40f0384c --- /dev/null +++ b/tix/tests/general/options.tcl @@ -0,0 +1,17 @@ +proc About {} { + return "Testing the option configuration of the Tix widgets" +} + +proc Test {} { + test {tixComboBox .c -xxxxx} {missing} + test {tixComboBox .c -xxxxx xxx} {unknown} + test {tixComboBox .c -d xxx} {ambi} + test {tixComboBox .c -disab 0} {ambi} + test {tixComboBox .c -disablecal 0} + Assert {[.c cget -disablecallback] == 0} + Assert {[.c cget -disableca] == 0} + test {tixComboBox .d -histl 10} + Assert {[.d cget -histlimit] == 10} + Assert {[.d cget -histlim] == 10} + Assert {[.d cget -historylimit] == 10} +} diff --git a/tix/tests/general/optmenu.tcl b/tix/tests/general/optmenu.tcl new file mode 100644 index 00000000000..6b0ea0150a2 --- /dev/null +++ b/tix/tests/general/optmenu.tcl @@ -0,0 +1,105 @@ +proc About {} { + return "Testing Option Menu widget" +} + +proc Test {} { + tixOptionMenu .p -label "From File Format : " -command "selectproc input" \ + -disablecallback 1 \ + -options { + label.width 19 + label.anchor e + menubutton.width 15 + } + + pack .p + + .p add command text -label "Plain Text" + .p add command post -label "PostScript" + .p add command format -label "Formatted Text" + .p add command html -label "HTML" + .p add separator sep + .p add command tex -label "LaTeX" + .p add command rtf -label "Rich Text Format" + + update + + foreach ent [.p entries] { + test {.p delete $ent} + } + + Assert {[.p subwidget menubutton cget -text] == {}} + + test {destroy .p} + + # Testing deleting "sep" at the end + # + tixOptionMenu .p -label "From File Format : " -command "selectproc input" \ + -disablecallback 1 \ + -options { + label.width 19 + label.anchor e + menubutton.width 15 + } + + + pack .p + + .p add command text -label "Plain Text" + .p add command post -label "PostScript" + .p add command format -label "Formatted Text" + .p add command html -label "HTML" + .p add separator sep + .p add command tex -label "LaTeX" + .p add command rtf -label "Rich Text Format" + + test {.p delete text} + test {.p delete post} + test {.p delete html} + test {.p delete format} + test {.p delete tex} + test {.p delete rtf} + test {.p delete sep} + + Assert {[.p subwidget menubutton cget -text] == {}} + test {destroy .p} + + # Testing deleting "sep" as the second-last one + # + tixOptionMenu .p -label "From File Format : " -command "selectproc input" \ + -disablecallback 1 \ + -options { + label.width 19 + label.anchor e + menubutton.width 15 + } + + + pack .p + + .p add command text -label "Plain Text" + .p add command post -label "PostScript" + .p add command format -label "Formatted Text" + .p add command html -label "HTML" + .p add separator sep + .p add command tex -label "LaTeX" + .p add command rtf -label "Rich Text Format" + + test {.p delete text} + global .p + Assert {[info exists .p(text,type)] == 0} + Assert {[info exists .p(text,name)] == 0} + Assert {[info exists .p(text,label)] == 0} + test {.p delete post} + test {.p delete html} + test {.p delete format} + test {.p delete tex} + + Assert {[.p cget -value] == "rtf"} + test {.p delete sep} + Assert {[.p cget -value] == "rtf"} + test {.p delete rtf} + + Assert {[.p subwidget menubutton cget -text] == {}} + + test {destroy .p} +} diff --git a/tix/tests/general/pane.tcl b/tix/tests/general/pane.tcl new file mode 100644 index 00000000000..918386794ce --- /dev/null +++ b/tix/tests/general/pane.tcl @@ -0,0 +1,29 @@ +# pane.tcl -- +# +# Test the PanedWindow widget. +# +# Copyright (c) 1996, Expert Interface Technologies +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +proc About {} { + return "Test the PanedWindow widget." +} + +proc Test {} { + TestBlock pane-1.1 {tixPanedWindow -expand} { + tixPanedWindow .p -orient horizontal + pack .p -expand yes -fill both + set p1 [.p add pane1 -expand 0.3] + set p2 [.p add pane2 -expand 1] + set p3 [.p add pane3 -size 20] + .p config -width 300 -height 200 + update + .p config -width 500 + update + .p config -width 200 + update + } +} diff --git a/tix/tests/general/pkginit.tcl b/tix/tests/general/pkginit.tcl new file mode 100644 index 00000000000..6f0dbc39038 --- /dev/null +++ b/tix/tests/general/pkginit.tcl @@ -0,0 +1,6 @@ +# pkginit.tcl -- +# +# +# This file contains the initialization code for all the test programs +# in this directory. +# diff --git a/tix/tests/general/samples.tcl b/tix/tests/general/samples.tcl new file mode 100644 index 00000000000..4c39834ea53 --- /dev/null +++ b/tix/tests/general/samples.tcl @@ -0,0 +1,73 @@ +# samples.tcl -- +# +# Tests all the sample programs in the demo/samples directory. +# +# +# Copyright (c) 1996, Expert Interface Technologies +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +proc About {} { + return "Testing all the sample programs in the demo/samples directory" +} + +proc Test {} { + global samples_dir demo_dir tix_library + + TestBlock samples-1.0 "Finding the demo directory" { + foreach dir "$tix_library/demos $tix_library/../demos ../../demos ../demos demos" { + if {[file exists $dir] && [file isdir $dir]} { + set pwd [pwd] + cd $dir + set demo_dir [pwd] + set samples_dir [pwd]/samples + cd $pwd + break + } + } + } + + if ![info exists samples_dir] { + puts "Cannot find demos directory. Sample tests are skipped" + return + } else { + puts "loading demos from $demo_dir" + } + + TestBlock samples-1.1 "Running widget demo" { + if [file exists $demo_dir/widget] { + uplevel #0 source [list $demo_dir/widget] + Widget:SelfTest + } + } + if ![file exists $samples_dir/AllSampl.tcl] { + return + } + uplevel #0 source [list $samples_dir/AllSampl.tcl] + + ForAllSamples root "" Test_Sample +} + + +proc Test_Sample {token type text dest} { + global samples_dir tix_demo_running + + set tix_demo_running 1 + + if {$type == "f"} { + set w .sampl_top + TestBlock samples-2-$dest "Loading sample $dest" { + uplevel #0 source [list $samples_dir/$dest] + toplevel $w + wm geometry $w +100+100 + wm title $w $text + RunSample $w + update + } + catch { + destroy $w + } + } +} diff --git a/tix/tests/general/select.tcl b/tix/tests/general/select.tcl new file mode 100644 index 00000000000..5a10b815ae7 --- /dev/null +++ b/tix/tests/general/select.tcl @@ -0,0 +1,45 @@ +proc About {} { + return "Testing the TixSelect widget" +} + +proc Test {} { + set dis [tix option get disabled_fg] + set norm [tix option get fg] + + # Create with a normal state + # + # + tixSelect .foo -allowzero 0 -radio 1 -label "Foo:" \ + -state normal + .foo add "1" -text "One" + .foo add "2" -text "Two" + pack .foo + + Assert {[.foo subwidget label cget -foreground] == $norm} + .foo config -state normal + .foo config -state normal + Assert {[.foo subwidget label cget -foreground] == $norm} + .foo config -state disabled + Assert {[.foo subwidget label cget -foreground] == $dis} + .foo config -state normal + Assert {[.foo subwidget label cget -foreground] == $norm} + + update + destroy .foo + + tixSelect .foo -allowzero 0 -radio 1 -label "Foo:" \ + -state disabled + .foo add "1" -text "One" + .foo add "2" -text "Two" + pack .foo + + Assert {[.foo subwidget label cget -foreground] == $dis} + .foo config -state normal + Assert {[.foo subwidget label cget -foreground] == $norm} + .foo config -state normal + Assert {[.foo subwidget label cget -foreground] == $norm} + .foo config -state disabled + Assert {[.foo subwidget label cget -foreground] == $dis} + .foo config -state normal + Assert {[.foo subwidget label cget -foreground] == $norm} +} diff --git a/tix/tests/general/slistbox.tcl b/tix/tests/general/slistbox.tcl new file mode 100644 index 00000000000..4a670d8369b --- /dev/null +++ b/tix/tests/general/slistbox.tcl @@ -0,0 +1,16 @@ +proc About {} { + return "Testing ScrolledListBox" +} + +proc Test {} { + set w [tixScrolledListBox .listbox] + pack $w + + foreach item {{1 1} 2 3 4 5 6} { + $w subwidget listbox insert end $item + } + + Click [$w subwidget listbox] 30 30 + + destroy $w +} diff --git a/tix/tests/general/testtmpl.tcl b/tix/tests/general/testtmpl.tcl new file mode 100644 index 00000000000..ddaf80166c7 --- /dev/null +++ b/tix/tests/general/testtmpl.tcl @@ -0,0 +1,28 @@ +# testtmpl.tcl -- +# +# Test Template: +# +# This program is used as the first test: see whether we can execute any +# case at all. +# +# This program is also used as a template file for writing other test +# cases. +# +# Copyright (c) 1996, Expert Interface Technologies +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +proc About {} { + return "Testing whether the test program starts up properly" +} + +proc Test {} { + TestBlock testtmpl-1.1 {NULL test} { + # + # If this fails, we are in big trouble and probably none of the + # tests can pass. Abort all the tests + # + } 1 abortall +} diff --git a/tix/tests/general/var1.tcl b/tix/tests/general/var1.tcl new file mode 100644 index 00000000000..7422821fe71 --- /dev/null +++ b/tix/tests/general/var1.tcl @@ -0,0 +1,59 @@ +proc About {} { + return "Testing -variable option with Tix widgets" +} + +proc Test {} { + global foo bar arr + + set classes {tixControl tixComboBox} + set value 1234 + + foreach class $classes { + set w [$class .foo] + pack $w + update idletasks + + TestBlock var1-1.1 {$class: config -variable with initialized value} { + set bar $value + $w config -variable bar + update idletasks + Assert {[$w cget -value] == $value} + } + + TestBlock var1-1.2 {$class: config -variable w/ uninitialized value} { + destroy $w + set w [$class .foo] + $w config -variable bar + Assert {[$w cget -value] == $bar} + } + + TestBlock var1-1.2 {$class: config -variable} { + set foo 111 + $w config -variable foo + update idletasks + Assert {[$w cget -value] == $foo} + } + + TestBlock var1-1.2 {$class: config -value} { + $w config -value 123 + Assert {[$w cget -value] == 123} + Assert {[set [$w cget -variable]] == 123} + } + + TestBlock var1-1.2 {$class: config -variable on array variable} { + set arr(12) 1234 + $w config -variable arr(12) + Assert {[$w cget -value] == $arr(12)} + } + + TestBlock var1-1.2 {$class: config -value on array variable} { + $w config -value 12 + Assert {[$w cget -value] == 12} + Assert {[set [$w cget -variable]] == 12} + } + + catch { + destroy $w + } + } +} diff --git a/tix/tests/grid/Grid.tcl b/tix/tests/grid/Grid.tcl new file mode 100644 index 00000000000..0c37b0fdce2 --- /dev/null +++ b/tix/tests/grid/Grid.tcl @@ -0,0 +1,155 @@ +# This tests the Grid widget. +# +# +# +proc About {} { + return "Basic tests for the Grid widget" +} + +proc Test {} { + TestBlock grid-1.1 {Grid creation} { + test {tixGrid} {args} + test {tixGrid .g -ff} {unknown} + test {tixGrid .g -width} {missing} + + Assert {[info command .g] == {}} + Assert {![winfo exists .g]} + } + + TestBlock grid-1.2 {Grid creation} { + set g [tixGrid .g] + pack $g -expand yes -fill both + update + destroy $g + } + + TestBlock grid-2.1 {Grid widget commands} { + set g [tixGrid .g] + pack $g -expand yes -fill both + test {$g} {args} + set foo "" + } + TestBlock grid-2.2 {Grid widget commands} { + $g config -selectmode browse + Assert {[tixStrEq [$g cget -selectmode] browse]} + } + + #---------------------------------------- + # Sites + #---------------------------------------- + foreach cmd {anchor dragsite dropsite} { + TestBlock grid-3.1 "Grid \"$cmd\" widget command" { + test1 {$g $cmd} \ + "wrong # args: should be \".g $cmd option ?x y?\"" + } + TestBlock grid-3.2 "Grid \"$cmd\" widget command" { + test1 {$g $cmd foo} \ + {wrong option "foo", must be clear, get or set} + } + TestBlock grid-3.3 "Grid \"$cmd\" widget command" { + test1 {$g $cmd clear bar} \ + "wrong # of arguments, must be: .g $cmd clear" + } + TestBlock grid-3.4 "Grid \"$cmd\" widget command" { + test1 {$g $cmd set 0 0 bar} \ + "wrong # args: should be \".g $cmd option ?x y?\"" + } + TestBlock grid-3.5 "Grid \"$cmd\" widget command" { + test1 {$g $cmd set xxx 0} \ + {expected integer but got "xxx"} + } + TestBlock grid-3.6 "Grid \"$cmd\" widget command" { + test1 {$g $cmd set 0 xxx} \ + {expected integer but got "xxx"} + } + foreach selunit {row column cell} { + TestBlock grid-3.7 "Grid \"$cmd\" widget command" { + $g config -selectunit $selunit + $g $cmd set 0 0 + update + } + } + TestBlock grid-3.8 "Grid \"$cmd\" widget command" { + $g $cmd set 0 0 + Assert {[tixStrEq [$g $cmd get] "0 0"]} + } + TestBlock grid-3.9 "Grid \"$cmd\" widget command" { + $g $cmd set -20 -0 + Assert {[tixStrEq [$g $cmd get] "0 0"]} + } + TestBlock grid-3.10 "Grid \"$cmd\" widget command" { + $g $cmd set 10000000 100000000 + Assert {[tixStrEq [$g $cmd get] "10000000 100000000"]} + } + } + + #---------------------------------------- + # set + #---------------------------------------- + TestBlock grid-4.1 {Grid "set" widget command} { + test {$g set} {args} + test {$g set 0 0 -foo} {missing} + test {$g set 0 0 -foo bar} {unknown} + test {$g set 0 0 -itemtype foo} {unknown} + test {$g set 0 0 -itemtype imagetext -image foo} {image} + test {$g set 0 0 -itemtype imagetext -text Hello -image \ + [tix getimage folder] + } + update + } + + TestBlock grid-4.2 {Grid "set" widget command} { + for {set x 0} {$x < 19} {incr x} { + for {set y 0} {$y < 13} {incr y} { + $g set $x $y -itemtype imagetext -text ($x,$y) \ + -image [tix getimage folder] + } + } + update + } + + TestBlock grid-4.3 {Grid "unset" widget command} { + for {set x 0} {$x < 23} {incr x} { + for {set y 0} {$y < 19} {incr y} { + $g unset $x $y + } + } + update + } + + + #---------------------------------------- + # delete + #---------------------------------------- + TestBlock grid-5.1 {Grid "delete" widget command} { + for {set x 0} {$x < 19} {incr x} { + for {set y 0} {$y < 13} {incr y} { + $g set $x $y -itemtype imagetext -text ($x,$y) \ + -image [tix getimage folder] + } + } + foreach index {0 1 3 2 6 3 1 1 max 19 13 max} { + $g delete row $index + $g delete col $index + update + } + } + #---------------------------------------- + # move + #---------------------------------------- + TestBlock grid-6.1 {Grid "move" widget command} { + for {set x 0} {$x < 19} {incr x} { + for {set y 0} {$y < 13} {incr y} { + $g set $x $y -itemtype imagetext -text ($x,$y) \ + -image [tix getimage folder] + } + } + foreach index {0 1 3 2 6 3 1 1 max 19 13 max} { + $g move row $index $index 3 + $g move col $index $index -2 + update + } + } + +} + diff --git a/tix/tests/grid/files b/tix/tests/grid/files new file mode 100644 index 00000000000..627c7bff522 --- /dev/null +++ b/tix/tests/grid/files @@ -0,0 +1 @@ +Grid.tcl
\ No newline at end of file diff --git a/tix/tests/hlist/DirList.tcl b/tix/tests/hlist/DirList.tcl new file mode 100644 index 00000000000..3c4abe93309 --- /dev/null +++ b/tix/tests/hlist/DirList.tcl @@ -0,0 +1,51 @@ +# This file tests the pixmap image reader +# + +proc About {} { + return "This file performs test on the DirList widget" +} + +proc Test {} { + set w .dirlist + + tixDirList $w + pack $w + + set h [$w subwidget hlist] + + # If we didn't specifi -value, the DirList should display the + # current directory + Assert {[tixStrEq [$w cget -value] [tixFSPWD]]} + + # After changing the directory, the selection and anchor should change as + # well + set root [$h info children ""] + ClickHListEntry $h $root single + Assert {[tixStrEq [$w cget -value] [$h info data $root]]} + Assert {[tixStrEq [$h info selection] $root]} + Assert {[tixStrEq [$h info anchor] $root]} + + case [tix platform] { + unix { + set dir1 /etc + set dir2 /etc + } + windows { + set dir1 C:\\Windows + set dir2 C:\\Backup + } + default { + return + } + } + + foreach dir [list $dir1 $dir2] { + if ![file exists $dir] { + continue + } + + $w config -value $dir + Assert {[tixStrEq [$w cget -value] $dir]} + Assert {[tixStrEq [$h info data [$h info anchor]] $dir]} + } +} diff --git a/tix/tests/hlist/HLHdr.tcl b/tix/tests/hlist/HLHdr.tcl new file mode 100644 index 00000000000..22f295c0eea --- /dev/null +++ b/tix/tests/hlist/HLHdr.tcl @@ -0,0 +1,94 @@ +# This tests the "header" functions in HList +# +# +# Assumptions: +# (1) add command OK +# + +proc test {cmd {result {}} {ret {}}} { + if [catch {set ret [uplevel 1 $cmd]} err] { + set done 0 + foreach r $result { + if [regexp $r $err] { + puts "error message OK: $err" + set done 1 + break + } + } + if {!$done} { + error $err + } + } else { + puts "execution OK: $cmd" + } + return $ret +} + +set h [tixHList .h -header 1 -columns 2] +pack $h -expand yes -fill both +$h add hello -text hello +$h add noind -text hello + +test {$h header} {args} +test {$h header bad} {unknown} + +# Test for create +# +# + +test {$h header create} {args} +test {$h header create 3} {{exist}} +test {$h header create 1 -itemtype} {missing} +test {$h header create 1 -itemtype bad} {unknown} +test {$h header create 1 -itemtype imagetext -text Hello -image [tix getimage folder]} + + +# Test for cget +# +test {$h header cget} {args} +test {$h header cget 0 -text} {does not have} +test {$h header cget 1} {args} +test {$h header cget 3 -text} {exist} +test {$h header cget 1 arg arg} {args} +test {$h header cget 1 -bad} {{unknown}} +test {$h header cget 1 -text} + +# Test for config +# +test {$h header config} {args} +test {$h header config 3 -text} {exist} +test {$h header config 0 -text} {does not have} +test {$h header config 1 -bad} {{unknown}} +test {$h header config 1} +test {$h header config 1 -text} +test {$h header config 1 -text Hi} + +# Test for size +# +test {$h header size} {args} +test {$h header size 0 0} {args} +test {$h header size 4} {exist} +test {$h header size 0} {not have} +test {puts [$h header size 1]} + + +# Test for exist +# +test {$h header exist} {args} +test {$h header exist hello hi} {args} +test {$h header exist 4} {exist} +test {puts [$h header exist 0]} +test {puts [$h header exist 1]} + +# Test for delete +# +test {$h header delete} {args} +test {$h header delete hello hi} {args} +test {$h header delete 4} {exist} +test {$h header delete 0} {not have} +test {$h header delete 1} + +# just do it again .. +# +test {$h header create 1 -itemtype imagetext -text Hello -image [tix getimage folder]} + diff --git a/tix/tests/hlist/HLInd.tcl b/tix/tests/hlist/HLInd.tcl new file mode 100644 index 00000000000..ed4f127366e --- /dev/null +++ b/tix/tests/hlist/HLInd.tcl @@ -0,0 +1,51 @@ +proc Test {} { + set h [tixHList .h -indicator 1 -indent 20] + pack $h -expand yes -fill both + button .b -text close -command "Done forced" + pack .b + + $h add hello -text hello + $h add noind -text hello + + test {$h indicator} {args} + test {$h indicator bad} {unknown} + + # Test for create + # + # + + test {$h indicator create} {args} + test {$h indicator create xyz} {{not found}} + test {$h indicator create hello -itemtype} {missing} + test {$h indicator create hello -itemtype bad} {unknown} + test {$h indicator create hello -itemtype imagetext \ + -image [tix getimage plus]} + + # Test for cget + # + test {$h indicator cget} {args} + test {$h indicator cget hello} {args} + test {$h indicator cget hello arg arg} {args} + test {$h indicator cget noind -text} {{does not have}} + test {$h indicator cget hello -bad} {{unknown}} + test {$h indicator cget hello -image} + + # Test for size + # + test {$h indicator size} {args} + test {$h indicator size hello hi} {args} + test {$h indicator size bad} {{not found}} + test {$h indicator size noind} {{does not have}} + test {set x [$h indicator size hello]} + test {$h indicator cget hello -image} {{does not}} + + # Test for delete + # + test {$h indicator delete} {args} + test {$h indicator delete hello hi} {args} + test {$h indicator delete bad} {{not found}} + test {$h indicator delete hello} + test {$h indicator cget hello -image} {{does not}} + + update +} diff --git a/tix/tests/hlist/HList.tcl b/tix/tests/hlist/HList.tcl new file mode 100644 index 00000000000..16b6373e403 --- /dev/null +++ b/tix/tests/hlist/HList.tcl @@ -0,0 +1,76 @@ +# HList.tcl -- +# +# General HList test. +# +# Copyright (c) 1996, Expert Interface Technologies +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +proc About {} { + return "General tests for the HList widget" +} + + +proc Test {} { + set h [tixHList .h -selectmode single] + pack $h -expand yes -fill both + + # + PutP "Testing the selection command" + # + + for {set x 0} {$x < 40} {incr x} { + $h add foo$x -text Foo$x + } + update + + test {$h selection set} {arg} + test {$h selection set foo1} + + test {$h selection get foo} {arg} + Assert {[tixStrEq [$h selection get] "foo1"]} + Assert {[tixStrEq [$h selection get] [$h info selection]]} + + # + PutP "Testing the info bbox command" + # + $h config -browsecmd "HLTest_BrowseCmd $h" + global hlTest_selected + for {set x 0} {$x <= 3} {incr x} { + set ent foo[expr $x * 8] + $h see $ent + update + + set bbox [$h info bbox $ent] + Assert {![tixStrEq "$bbox" ""]} + + set hlTest_selected "" + Click $h [lindex $bbox 0] [lindex $bbox 1] + update + Assert {[tixStrEq "$hlTest_selected" "$ent"]} + + set hlTest_selected "" + Click $h [lindex $bbox 2] [lindex $bbox 3] + update + Assert {[tixStrEq "$hlTest_selected" "$ent"]} + } + + # + PutP "Testing the ClickHListEntry test function" + # + for {set x 0} {$x <= 3} {incr x} { + set hlTest_selected "" + set ent foo[expr $x * 8] + ClickHListEntry $h $ent + update + Assert {[tixStrEq "$hlTest_selected" "$ent"]} + } +} + +proc HLTest_BrowseCmd {w args} { + global hlTest_selected + + set hlTest_selected [tixEvent value] +} diff --git a/tix/tests/hlist/files b/tix/tests/hlist/files new file mode 100644 index 00000000000..1098edb1e57 --- /dev/null +++ b/tix/tests/hlist/files @@ -0,0 +1,3 @@ +HLInd.tcl +DirList.tcl +items.tcl
\ No newline at end of file diff --git a/tix/tests/hlist/items.tcl b/tix/tests/hlist/items.tcl new file mode 100644 index 00000000000..a961025b095 --- /dev/null +++ b/tix/tests/hlist/items.tcl @@ -0,0 +1,40 @@ +# items.tcl -- +# +# Test the handling of DisplayStyle and DisplayItem. +# +# Copyright (c) 1996, Expert Interface Technologies +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +proc About {} { + return "Test the handling of DisplayStyle and DisplayItem." +} + +proc Test {} { + TestBlock items-1.1 {tixTmpLine} { + tixHList .c + set style [tixDisplayStyle text -refwindow .c -font fixed] + .c add a -itemtype text -style $style -text Hello + .c add b -itemtype text -text Hello + + tixHList .d + .d add a -itemtype text -style $style -text Hello + .d add b -itemtype text -text Hello + + pack .c .d -expand yes -fill both + update + + destroy .c + update + Assert {[string comp [info command $style] ""] == 0} + } + + catch { + destroy .c + } + catch { + destroy .d + } +} diff --git a/tix/tests/itcl/files b/tix/tests/itcl/files new file mode 100644 index 00000000000..49446caf31e --- /dev/null +++ b/tix/tests/itcl/files @@ -0,0 +1,5 @@ +general.tcl +scope1.tcl +namesp.tcl +itk.tcl + diff --git a/tix/tests/itcl/general.tcl b/tix/tests/itcl/general.tcl new file mode 100644 index 00000000000..f6e4fb269a8 --- /dev/null +++ b/tix/tests/itcl/general.tcl @@ -0,0 +1,9 @@ +# ITcl general test +# + +proc About {} { + return "This file performs general test on Tix w/ ITcl 2.0" +} + +proc Test {} { +} diff --git a/tix/tests/itcl/itk.tcl b/tix/tests/itcl/itk.tcl new file mode 100644 index 00000000000..e93e3cc1438 --- /dev/null +++ b/tix/tests/itcl/itk.tcl @@ -0,0 +1,24 @@ +# This file tests the pixmap image reader +# + +proc About {} { + return "This file performs tests with ITK mega widgets" +} + +proc Test {} { + frame .f + pack .f + tixPanedWindow .f.tpw + pack .f.tpw -side left -expand yes -fill both + set p1 [.f.tpw add t1 -min 20 -size 120 ] + set p2 [.f.tpw add t2 -min 20 -size 80 ] + frame $p1.t1 + frame $p2.t2 + pack $p1.t1 $p2.t2 + tixScrolledListBox $p1.t1.list + tixScrolledListBox $p2.t2.list + pack $p1.t1.list $p2.t2.list + + Combobox .ibox -labeltext "ItkBox" -items {one two three} + pack .ibox +} diff --git a/tix/tests/itcl/namesp.tcl b/tix/tests/itcl/namesp.tcl new file mode 100644 index 00000000000..0f565242093 --- /dev/null +++ b/tix/tests/itcl/namesp.tcl @@ -0,0 +1,22 @@ +# This file tests the pixmap image reader +# + +proc About {} { + return "This file performs test on name space" +} + +proc Test {} { + namespace mySpace { + variable hsl ".hsl" + proc creatHSL {} { + global hsl + tixScrolledHList $hsl + } + proc packHSL {} { + global hsl + pack $hsl + } + } + mySpace::creatHSL + mySpace::packHSL +} diff --git a/tix/tests/itcl/pkginit.tcl b/tix/tests/itcl/pkginit.tcl new file mode 100644 index 00000000000..f3040cd641e --- /dev/null +++ b/tix/tests/itcl/pkginit.tcl @@ -0,0 +1,2 @@ +#@scope :: {lappend auto_path $env(IWIDGETS_LIBRARY)} +#@scope :: {source "$env(IWIDGETS_LIBRARY)/init.iwidgets"} diff --git a/tix/tests/itcl/scope1.tcl b/tix/tests/itcl/scope1.tcl new file mode 100644 index 00000000000..41cd8075861 --- /dev/null +++ b/tix/tests/itcl/scope1.tcl @@ -0,0 +1,54 @@ +proc About {} { + return "Testing creation of Tix widgets inside ITCL classes" +} + +proc Test {} { + class foo { + inherit itk::Widget + + constructor {args} { + itk_component add lab { + label $itk_interior.lab \ + -textvariable [code choice($this)] + } + + itk_component add le { + tixOptionMenu $itk_interior.le \ + -label "File format" \ + -variable [code choice($this)] \ + -command "$this foocmd" + } + + foreach cmd {HTML PostScript ASCII} { + $itk_component(le) add command $cmd + } + + pack $itk_component(lab) $itk_component(le) \ + -anchor e \ + -padx 10 \ + -pady 10 \ + -fill x + + eval itk_initialize $args + } + common choice + + method foocmd {args} { + puts $args + } + method set_format {format} { + set choice($this) $format + } + } + usual TixOptionMenu { + } + + foo .xy + pack .xy + .xy set_format ASCII + update + .xy component le config -value PostScript + update + .xy component le config -value HTML +} + diff --git a/tix/tests/library/CaseData.tcl b/tix/tests/library/CaseData.tcl new file mode 100644 index 00000000000..1d0c9195980 --- /dev/null +++ b/tix/tests/library/CaseData.tcl @@ -0,0 +1,148 @@ +# CaseData.tcl -- +# +# Contains data for test cases +# +# Copyright (c) 1996, Expert Interface Technologies +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +# GetHomeDirs -- +# +# Returns a list of user names (prefixed with tilde) and their +# home directories +# +proc GetHomeDirs {} { + set tryList {root ftp admin operator uucp adm man john ioi} + if [catch { + lappend tryList [exec whoami] + }] { + catch { + lappend tryList [exec logname] + } + } + + + set list {} + foreach user $tryList { + if [info exists done($user)] { + continue + } + set expanded [tixFile tilde ~$user] + if ![tixStrEq $expanded ~$user] { + lappend list [list ~$user $expanded] + } + set done($user) 1 + } + return $list +} + +# GetCases_FsNormDir -- +# +# Returns a set of test cases for verifying whether a non-normalized +# directory is properly notmalized +# +proc GetCases_FsNormDir {} { + + if [tixStrEq [tix platform] unix] { + # PATHNAME to TEST expected result Causes error for + # tixFSNormDir? + #---------------------------------------------------------------- + set list { + {. "" 1} + {foo "" 1} + {~nosuchuser "" 1} + {~nosuchuser/../ "" 1} + {/ / 0} + {/// / 0} + {/./ / 0} + {/./. / 0} + {/./. / 0} + {/././.././../ / 0} + {/etc /etc 0} + {/etc/../etc /etc 0} + {/etc/../etc/./ /etc 0} + {/etc/../etc/./ /etc 0} + {/etc/../usr/./lib /usr/lib 0} + } + foreach userInfo [GetHomeDirs] { + lappend list [list [lindex $userInfo 0] [lindex $userInfo 1] 0] + } + } else { + set list [list \ + [list . "" 1] \ + [list foo "" 1] \ + [list .. "" 1] \ + [list ..\\foo "" 1] \ + [list ..\\dat\\. "" 1] \ + [list C: "" 1] \ + [list C:\\ C: 0] \ + [list c:\\ C: 0] \ + [list C:\\\\ C: 0] \ + [list C:\\ C: 0] \ + [list C:\\. C: 0] \ + [list C:\\Windows C:\\Windows 0] \ + [list C:\\Windows\\System C:\\Windows\\System 0] \ + [list C:\\Windows\\.. C: 0] \ + ] + } + + return $list +} + +# GetCases_FSNorm -- +# +# Returns a set of test cases for testing the tixFSNorm command. +# +proc GetCases_FSNorm {} { + global tixPriv + + if [tixStrEq [tix platform] unix] { + # PATHNAME to TEST context <---------- Expected Result -----------------------------------> + # path vpath(todo) files(todo) patterns(todo) + #---------------------------------------------------------------- + set list { + {. / / } + {./ / / } + {./////./ / / } + {.. / / } + {../ / / } + {../.. / / } + {../../../ / / } + {/etc / /etc } + {/etc///../etc/// / /etc } + {/etc///../etc///.. / / } + {/etc///../etc///../ / / } + {/etc/. / /etc } + {/./etc/. / /etc } + {/./././etc/. / /etc } + {/usr/./././local/./lib//// / /usr/local/lib } + {./././././etc/ / /etc } + {/etc/../etc / /etc } + {/etc/../etc/../etc / /etc } + {/etc/../etc/../ / / } + {~foobar/foo / /~foobar } + {~foobar/foo/ / /~foobar/foo } + } + } else { + set p $tixPriv(WinPrefix) + + set list [list \ + [list . $p\\C: $p\\C: ] \ + [list .\\. $p\\C: $p\\C: ] \ + [list .\\Windows $p\\C: $p\\C:\\Windows ] \ + [list .\\Windows\\..\\ $p\\C: $p\\C: ] \ + [list tmp\\ $p\\C: $p\\C:\\tmp ] \ + [list "no such file" $p\\C: $p\\C: ] \ + [list "autoexec.bat" $p\\C: $p\\C: ] \ + [list "ignore/slash\\dd" $p\\C: $p\\C:\\ignore/slash ] \ + [list "has space\\" $p\\C: "$p\\C:\\has space" ] \ + [list "has space" $p\\C: "$p\\C:" ] \ + ] + # ToDo: + # (1) xx\xx\C: + .. should be xx\xx + # (2) xx\xx\C: + D: should be xx\xx\D: + } + return $list +} diff --git a/tix/tests/library/TestLib.tcl b/tix/tests/library/TestLib.tcl new file mode 100644 index 00000000000..31b7320e305 --- /dev/null +++ b/tix/tests/library/TestLib.tcl @@ -0,0 +1,598 @@ +# TestLib.tcl -- +# +# Implements the procedures used by the Tix test suite. +# +# Copyright (c) 1996, Expert Interface Technologies +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +set testapp(tix,w,normal) { + tixButtonBox tixComboBox tixControl tixDirList tixDirTree + tixExDirSelectBox tixExFileSelectBox tixFileSelectBox tixFileEntry + tixLabelEntry tixLabelFrame tixNoteBook tixOptionMenu + tixPanedWindow tixScrolledHList tixScrolledListBox + tixScrolledTList tixScrolledText tixScrolledWindow tixSelect + tixStdButtonBox tixTree +} +set testapp(tix,w,shell) { + tixBalloon tixDialogShell tixExFileSelectDialog tixFileSelectDialog + tixPopupMenu tixStdDialogShell +} +set testapp(tix,w,base) { + tixLabelWidget + tixPrimitive + tixScrolledWidget + tixShell + tixStackWindow + tixVResize tixVStack tixVTree +} +set testapp(tix,w,unsupported) { + tixMDIMenuBar + tixMDIWindow + tixMwmClient + tixResizeHandle + tixSimpleDialog + tixStatusBar +} + +# testConfig(VERBOSE) is the "Verbosity level" of the test suite. +# +# 0 -- No messages except the name of the tests +# 10 -- Print out the number of each test block +# 15 -- Print out the number and name of each test block +# 20 -- Print out all kinds of messages +# 30 -- level 20, plus when an error occurs, prints out the stack trace. +# +if [info exists env(TEST_VERBOSE)] { + if [catch { + set testConfig(VERBOSE) [expr "int($env(TEST_VERBOSE) + 0)"] + }] { + set testConfig(VERBOSE) 10 + } +} else { + set testConfig(VERBOSE) 0 +} + +set testConfig(errCount) 0 + +#---------------------------------------------------------------------- +# +# General assertion and evaluation +# +#---------------------------------------------------------------------- + +# Assert -- +# +# Evaulates an assertion. Output error message if the assertion is false +# +proc Assert {cond {printErrInfo 0} {abortMode abortfile}} { + global errorInfo testConfig + if [info exists errorInfo] { + set errorInfo "" + } + uplevel 1 [list \ + if !($cond) [list \ + TestError "Failed Assertion \"$cond\"\n evaluated as \"[uplevel 1 subst -nocommand [list $cond]]\" :: [uplevel 1 subst [list $cond]]" $printErrInfo $abortMode + ] \ + ] +} + +# TestAbort -- +# +# Aborts a single test file. +# +proc TestAbort {msg} { + error $msg +} + +# test -- +# +# Try to evaluate a command. +# +proc test {cmd {result {}} {ret {}}} { + global testConfig + + if [catch {set ret [uplevel 1 $cmd]} err] { + set done 0 + foreach r $result { + if [regexp $r $err] { + if {$testConfig(VERBOSE) >= 20} { + puts "Passed (Error message is expected):" + puts " command = \"$cmd\"" + puts " expected error = \"$result\"" + puts " actual error = $err" + } + set done 1 + break + } + } + if {!$done} { + error $err + } + } else { + if {$testConfig(VERBOSE) >= 20} { + puts "Passed (Execution OK):\n command = \"$cmd\"" + } + } + return $ret +} + +# test1 -- +# +# Try to evaluate a command and make sure its error result is the same +# as $result. +# +proc test1 {cmd {result {}}} { + global testConfig + + set ret "" + if [catch {set ret [uplevel 1 $cmd]} err] { + if ![tixStrEq $err $result] { + error $err + } else { + if {$testConfig(VERBOSE) >= 20} { + puts "Passed (Error message is expected):" + puts " command = \"$cmd\"" + puts " expected error = \"$result\"" + } + } + } else { + if {$testConfig(VERBOSE) >= 20} { + puts "Passed (Execution OK):\n command = \"$cmd\"" + } + } + return $ret +} + +#---------------------------------------------------------------------- +# +# Mouse event emulation routines +# +#---------------------------------------------------------------------- +proc GetRoot {w x y} { + upvar X X + upvar Y Y + + set x0 [winfo rootx $w] + set y0 [winfo rooty $w] + + set X [expr $x0 + $x] + set Y [expr $y0 + $y] +} + +proc MouseEvent {w type x y args} { + set tags [bindtags $w] + GetRoot $w $x $y + + lappend args %q + lappend args $w + lappend args %W + lappend args $w + lappend args %x + lappend args $x + lappend args %y + lappend args $y + lappend args %X + lappend args $X + lappend args %Y + lappend args $Y + + set found 0 + foreach t $tags { + set cmd [string trim [bind $t $type]] + + if {$cmd != ""} { + set found 1 + } + tixForEach {sub val} $args { + regsub -all $sub $cmd $val cmd + } + uplevel #0 $cmd + } + if {$found == 0} { + global testConfig + if $testConfig(VERBOSE) { + puts "(testlib warning): widget $w has no bindings for $type" + } + } + return $found +} + +# KeyboardString -- +# +# Send a string to the widget via a list of key strokes. This does +# NOT ensure that an entry widget has the exact content as $string. +# You need to call $entry delete 0 end first! +# +proc KeyboardString {w string} { + set tags [bindtags $w] + + lappend args %q + lappend args $w + lappend args %W + lappend args $w + + set found 0 + + foreach c [split $string ""] { + foreach t $tags { + set cmd [string trim [bind $t <KeyPress>]] + + if {$cmd != ""} { + set found 1 + } + set list $args + lappend list %A + lappend list [list $c] + + tixForEach {sub val} $list { + regsub -all $sub $cmd $val cmd + } + + # This is really weird. If our char is '\', the lappend line + # makes it a quoted \\, but the previous regsub makes it back + # to a single quote. So we use regsub again to make it a \\ + # again. But that's not enough, because uplevel will change it + # back to a single quote and will eventually mess us up. Hence + # we use quad-slashes here! + # + regsub -all {[\\]} $cmd {\\\\} cmd + uplevel #0 $cmd + } + } + if {$found == 0} { + puts "warning: widget $w has no bindings for $type" + } + return $found + +} + +# KeyboardEvent -- +# +# Send a special keyboard event to the widget. E.g., <Return> +# <space>, <Escape>, <BackSpace> etc. To send ascii character +# strings, use KeyboardString +# +proc KeyboardEvent {w type} { + set tags [bindtags $w] + + lappend args %q + lappend args $w + lappend args %W + lappend args $w + + set found 0 + foreach t $tags { + set cmd [string trim [bind $t $type]] + + if {$cmd != ""} { + set found 1 + } + tixForEach {sub val} $args { + regsub -all $sub $cmd $val cmd + } + uplevel #0 $cmd + } + if {$found == 0} { + puts "warning: widget $w has no bindings for $type" + } + return $found +} + +proc Event-Initialize {} { + global app + + set app(X) -1000 + set app(Y) -1000 + set app(curWid) {} +} + +proc InWidget {w} { + global app + + return [tixWithinWindow $w $app(X) $app(Y)] +} + +proc Leave {w {x -10} {y -10} args} { + global app + + eval MouseEvent $w <Leave> $x $y $args +} + +proc B1-Leave {w {x -10} {y -10} args} { + global app + + eval MouseEvent $w <Leave> $x $y $args +} + +proc RecordRoot {w x y} { + global app + + GetRoot $w $x $y + set app(X) $X + set app(Y) $Y +} + +proc Enter {w {x -1} {y -1} args} { + global app + + if {$y == -1} { + set x [expr [winfo width $w] / 2] + set y [expr [winfo height $w] / 2] + } + + if {$app(curWid) != {} && [winfo exists $app(curWid)]} { + Leave $app(curWid) + } + RecordRoot $w $x $y + + eval MouseEvent $w <Enter> $x $y $args + set app(curWid) $w +} + +proc Drag {w {x -1} {y -1} args} { + global app + + if {$y == -1} { + set x [expr [winfo width $w] / 2] + set y [expr [winfo height $w] / 2] + } + + if {![InWidget $w]} { + B1-Leave $w $x $y + } + + eval MouseEvent $w <B1-Motion> $x $y $args +} + +# Release -- +# +# Release mouse button 1 in a widget +# +proc Release {w {x -1} {y -1} args} { + global app + + if {$y == -1} { + set x [expr [winfo width $w] / 2] + set y [expr [winfo height $w] / 2] + } + eval MouseEvent $w <ButtonRelease-1> $x $y $args +} + +# Assumming the button was not originally down +# +proc HoldDown {w {x -1} {y -1} args} { + global app + + if {$y == -1} { + set x [expr [winfo width $w] / 2] + set y [expr [winfo height $w] / 2] + } + if {![InWidget $w]} { + Enter $w $x $y + } + + if {![eval MouseEvent $w <ButtonPress-1> $x $y $args]} { + eval MouseEvent $w <1> $x $y $args + } +} + +proc Click {w {x -1} {y -1} args} { + global app + + if {$y == -1} { + set x [expr [winfo width $w] / 2] + set y [expr [winfo height $w] / 2] + } + eval HoldDown $w $x $y $args + eval MouseEvent $w <ButtonRelease-1> $x $y $args +} + +proc Double {w {x -1} {y -1} args} { + global app + + if {$y == -1} { + set x [expr [winfo width $w] / 2] + set y [expr [winfo height $w] / 2] + } + eval MouseEvent $w <Double-1> $x $y $args +} + +# ClickListboxEntry -- +# +# Simulate the event where a listbox entry is clicked. +# Args: +# w:widget pathname of listbox +# index:LbIndex index of entry to be clicked. +# mode:string "single" or "double" indicating whether a single or +# double click is desired. +# +proc ClickListboxEntry {w index {mode single}} { + $w see $index + set bbox [$w bbox $index] + set x1 [lindex $bbox 0] + set y1 [lindex $bbox 1] + + if {$mode == "single"} { + Click $w $x1 $y1 + } else { + Double $w $x1 $y1 + } +} + +# ClickHListEntry -- +# +# Simulate the event where an HList entry is clicked. +# Args: +# w:widget pathname of HList +# index:HLIndex index of entry to be clicked. +# mode:string "single" or "double" indicating whether a single or +# double click is desired. +# +proc ClickHListEntry {w index {mode single}} { + $w see $index + update + set bbox [$w info bbox $index] + set x1 [lindex $bbox 0] + set y1 [lindex $bbox 1] + + if {$mode == "single"} { + Click $w $x1 $y1 + } else { + Double $w $x1 $y1 + } +} + +# InvokeComboBoxByKey -- +# +# Simulate the event when the user types in a string into the +# entry subwidget of a ComboBox widget and then type Return +# +proc InvokeComboBoxByKey {w string} { + set ent [$w subwidget entry] + $ent delete 0 end + KeyboardString $ent $string + KeyboardEvent $ent <Return> + update +} + +# SetComboBoxByKey -- +# +# Simulate the event when the user types in a string into the +# entry subwidget of a ComboBox widget, *without* a subsequent +# Return keystroke. +# +proc SetComboBoxByKey {w string} { + set ent [$w subwidget entry] + $ent delete 0 end + KeyboardString $ent $string + update +} + +#---------------------------------------------------------------------- +# +# main routines +# +#---------------------------------------------------------------------- + +proc Done {args} { + global testConfig + + if {$testConfig(VERBOSE) >= 20} { + puts "------------------------done--------------------------------" + } +} + +proc Wait {msecs} { + global Test:timer + set Test:timer 0 + after $msecs uplevel #0 set Test:timer 1 + tkwait variable Test:timer +} + +proc TestPuts {msg} { + puts $msg +} + +#---------------------------------------------------------------------- +# +# Messages +# +#---------------------------------------------------------------------- +proc PutP {msg} { + puts $msg +} +proc PutTitle {msg} { + puts $msg +} +proc PutSubTitle {msg} { + puts $msg +} +proc PutSubSubTitle {msg} { + puts $msg +} +proc TestWarn {msg} { + puts "Warning: $msg" +} +proc TestError {msg {printErrInfo 0} {abortMode cont}} { + global testConfig + puts " $msg" + case $abortMode { + cont { + if {$printErrInfo || $testConfig(VERBOSE) >= 30} { + global errorInfo + puts "\$errorInfo = $errorInfo" + } + return + } + abortfile { + return -code 1234 + } + abortall { + global errorInfo + puts "Aborting all test files because of the unrecoverable error:" + puts $errorInfo + exit 1 + } + } +} + +# TestBlock -- +# +# Performs a block of test. A block is mainly used to group +# together tests that are dependent on each other. TestBlocks +# may be nested. +# +# Args: +# name: Textual name of the test. E.g.: button-1.1 +# description: Short description of the test. "Pressing button" +# printErrInfo: If an error occurs, should the errorInfo be printed +# to the console. (Normally only a one-liner error +# message is printed). +# abortMode: cont -- skip this block and go to the next block +# abortfile -- skip all other blocks in this file +# abortall -- skip all the Tix tests. +# +proc TestBlock {name description script {printErrInfo 0} {abortMode cont}} { + global testConfig + + set code [catch {uplevel 1 $script} result] + + if {$testConfig(VERBOSE) >= 15} { + set des "($description)" + } else { + set des "" + } + + if {$code != 0} { + incr testConfig(errCount) + puts stdout "---- $name FAILED $des" + puts "Script is" + foreach line [split $script \n] { + regsub "^\[[format %s \ \n\t]\]*" $line "" line + puts " $line" + } + puts "Error message:" + TestError $result $printErrInfo $abortMode + puts stdout "----" + } elseif $testConfig(VERBOSE) { + puts stdout "++++ $name PASSED $des" + } +} + +#---------------------------------------------------------------------- +# +# general initialization +# +#---------------------------------------------------------------------- + +# init the event emulation +# + +# some window managers don't put the main window at a default place, this +# may be quite annoying for the user +# +wm geometry . +0+0 + diff --git a/tix/tests/library/TestLib.txt b/tix/tests/library/TestLib.txt new file mode 100644 index 00000000000..43aea02c9e2 --- /dev/null +++ b/tix/tests/library/TestLib.txt @@ -0,0 +1,53 @@ +HIGH LEVEL INTERFACE FOR INTERACTIVE TESTING +-------------------------------------------- +Click: + + Simulates a the event when a user moves the mouse pointer into + the widget (if the cursor is still outside of the widget), press + the button and release it. + + +Double: + + Simulates a the event when a user moves the mouse pointer into + the widget (if the cursor is still outside of the widget), double-click + the button and release it. + + +MESSAGE PRINTING +---------------- + +PutP + + Prints a progress message. + +PutTitle + + Prints the title of a test file + +PutSubTitle + + Print the title of a part of a test file + +PutSubSubTitle + + One more level than PutSubTitle + +TestWarn + + Print a warning message. This will be counted in the final report. + +TestError {msg {printErrInfo 0} {abortMode cont}} + + Print an error message. abortMode controls how the error affects + other test cases: + + cont: simply print the message and continue + abortfile: skip other test cases in this file + abortall: abort the all other tests and exit the test + program. + + printErrInfo specifies whether the "$errorInfo" variable should be + printed. + + diff --git a/tix/tests/library/load-init.tcl b/tix/tests/library/load-init.tcl new file mode 100644 index 00000000000..b383e8b8cb2 --- /dev/null +++ b/tix/tests/library/load-init.tcl @@ -0,0 +1,7 @@ +# +# +# + +puts -nonewline "trying to load the Tix dynamic library ... " +load ../../unix-tk4.1/libtix.so Tix +puts "done" diff --git a/tix/tests/load/files b/tix/tests/load/files new file mode 100644 index 00000000000..3026fe89955 --- /dev/null +++ b/tix/tests/load/files @@ -0,0 +1 @@ +general.tcl diff --git a/tix/tests/load/general.tcl b/tix/tests/load/general.tcl new file mode 100644 index 00000000000..e1744bcaef2 --- /dev/null +++ b/tix/tests/load/general.tcl @@ -0,0 +1,22 @@ +# This file tests the pixmap image reader +# + +proc About {} { + return "This file performs general test on Tix w/ Tk 4.1 dynamic loading" +} + +proc Test {} { + if [tixStrEq [info commands tix] tix] { + return + } + + if ![file exists ../../unix-tk4.1/libtix.so] { + puts "File ../../unix-tk4.1/libtix.so doesn't exist." + puts "Dynamic loading skipped." + return + } + + test {load ../../unix-tk4.1/libtix.so Tix} + test {tixComboBox .c} + test {pack .c} +} diff --git a/tix/tests/load/pkginit.tcl b/tix/tests/load/pkginit.tcl new file mode 100644 index 00000000000..e69de29bb2d --- /dev/null +++ b/tix/tests/load/pkginit.tcl diff --git a/tix/tests/tlist/TList.tcl b/tix/tests/tlist/TList.tcl new file mode 100644 index 00000000000..536f8b8c8f4 --- /dev/null +++ b/tix/tests/tlist/TList.tcl @@ -0,0 +1,38 @@ +# This tests the TList widget. +# +# +# Assumptions: +# None +# +proc About {} { + return "Basic tests for the TList widget" +} + +proc Test {} { + + # + # Test the creation + # + test {tixTList} {args} + test {tixTList .t -ff} {unknown} + test {tixTList .t -width} {missing} + + if {[info command .t] != {}} { + error "widget not destroyed when creation failed" + } + + set t [tixTList .t] + test {$t} {args} + + # + # Test the "insert" command + # + test {$t insert} {args} + test {$t insert 0 -foo} {missing} + test {$t insert 0 -foo bar} {unknown} + test {$t insert 0 -itemtype foo} {unknown} + test {$t insert 0 -itemtype text -image foo} {unknown} + test {$t insert 0 -itemtype text -text Hello} + + pack $t +} diff --git a/tix/tests/tlist/files b/tix/tests/tlist/files new file mode 100644 index 00000000000..7c39b5b8cac --- /dev/null +++ b/tix/tests/tlist/files @@ -0,0 +1 @@ +TList.tcl
\ No newline at end of file diff --git a/tix/tests/xpm/2cpp.xpm b/tix/tests/xpm/2cpp.xpm new file mode 100644 index 00000000000..bd559d249c3 --- /dev/null +++ b/tix/tests/xpm/2cpp.xpm @@ -0,0 +1,11 @@ +/* XPM */ +static char * folder_xpm[] = { +"4 4 3 2", + "AA c black", +".. c white", +"XY c yellow", +"AAAAAAXY", +"XYAAAAAA", +"..AA..AA", +"..AAAA..", +}; diff --git a/tix/tests/xpm/brace.xpm b/tix/tests/xpm/brace.xpm new file mode 100644 index 00000000000..805494c4ea9 --- /dev/null +++ b/tix/tests/xpm/brace.xpm @@ -0,0 +1,19 @@ +/* XPM */ +static char * tmp [] = { +/* width height ncolors cpp [x_hot y_hot] */ +"10 10 2 1 -1 -1", +/* colors */ +" s iconColor1 m black c gray", +"} s iconColor2 m white c white", +/* pixels */ +" ", +" ", +" ", +" ", +" ", +"}}}}}}}}}}", +"}}}}}}}}}}", +"}}}}}}}}}}", +"}}}}}}}}}}", +"}}}}}}}}}}"}; + diff --git a/tix/tests/xpm/comments.xpm b/tix/tests/xpm/comments.xpm new file mode 100644 index 00000000000..de45058d570 --- /dev/null +++ b/tix/tests/xpm/comments.xpm @@ -0,0 +1,21 @@ +/* XPM */ +static char * tmp [] = { +/* width height ncolors cpp [x_hot y_hot] */ +/* width height ncolors cpp [x_hot y_hot] */ /* Some comments */ +"10 10 2 1 -1 -1", +/* colors */ +" s iconColor1 m black c gray", +"} s iconColor2 m white c white", +/* pixels */ +" ", +" ", +" ", +" ", + /* Some comments */ +" ", +"}}}}}}}}}}", +"}}}}}}}}}}", +"}}}}}}}}}}" /* Some comments */, +"}}}}}}}}}}", +"}}}}}}}}}}" /* Some comments */}; + diff --git a/tix/tests/xpm/compound.tcl b/tix/tests/xpm/compound.tcl new file mode 100644 index 00000000000..603db3d39b3 --- /dev/null +++ b/tix/tests/xpm/compound.tcl @@ -0,0 +1,47 @@ +proc About {} { + return "the compound image type" +} + +proc Test {} { + set num 3 + # Test for create + # + # + test {image create compound -foo} {missing} + test {image create compound -window} {missing} + test {image create compound -window foo} {path name} + test {set image1 [image create compound -window .b]} {path name} + + for {set i 0} {$i < $num} {incr i} { + button .b$i + pack .b$i + } + + # (0) Empty image + # + test {set image0 [image create compound -window .b0]} + + # (1) Simple image + # + test {set image1 [image create compound -window .b1]} + + $image1 add line + $image1 add text -text Hello + + # (2) Two lines + # + test {set image2 [image create compound -window .b2]} + + $image2 add line + $image2 add text -text "Line One" + $image2 add line + $image2 add text -text "Line Two" + + + # Display them + # + for {set i 0} {$i < $num} {incr i} { + .b$i config -image [set image$i] + } + +} diff --git a/tix/tests/xpm/f-badcol.xpm b/tix/tests/xpm/f-badcol.xpm new file mode 100644 index 00000000000..7e27b863d43 --- /dev/null +++ b/tix/tests/xpm/f-badcol.xpm @@ -0,0 +1,21 @@ +/* XPM */ +static char * folder_xpm[] = { +/* width height num_colors chars_per_pixel */ +"16 12 3 1", +/* colors */ +" s None c None", +". c black", +"X c foooo", +/* pixels */ +" .... ", +" .XXXX. ", +" .XXXXXX. ", +"............. ", +".XXXXXXXXXXX. ", +".XXXXXXXXXXX. ", +".XXXXXXXXXXX. ", +".XXXXXXXXXXX. ", +".XXXXXXXXXXX. ", +".XXXXXXXXXXX. ", +".XXXXXXXXXXX. ", +"............. "}; diff --git a/tix/tests/xpm/f-badpix.xpm b/tix/tests/xpm/f-badpix.xpm new file mode 100644 index 00000000000..fdb4cb13f5b --- /dev/null +++ b/tix/tests/xpm/f-badpix.xpm @@ -0,0 +1,21 @@ +/* XPM */ +static char * folder_xpm[] = { +/* width height num_colors chars_per_pixel */ +"16 12 3 1", +/* colors */ +" s None c None", +". c black", +"X c #f0ff80", +/* pixels */ +" .... ", +" .XXXX. ", +" .XXXXXX. ", +"............. ", +".XBBBBBBXXXX. ", +".XXXXXXXXXXX. ", +".XXXXXXBBXXX. ", +".XXBBBBBBXXX. ", +".XXXXXXXXXXX. ", +".XXXXXXNNXXX. ", +".XXXXXXXXXXX. ", +"............. "}; diff --git a/tix/tests/xpm/f-commt.xpm b/tix/tests/xpm/f-commt.xpm new file mode 100644 index 00000000000..3158fd20782 --- /dev/null +++ b/tix/tests/xpm/f-commt.xpm @@ -0,0 +1,32 @@ +/* XPM */ +static char * folder_xpm[] = { +/* width height num_colors chars_per_pixel */ +"16 12 3 1", +/* colors */ +" s None c None", +". c black", +"X c #f0ff80", +/* pixels + +asd +a +sd +as +da +sd +asad + + + */ +" .... ", +" .XXXX. ", +" .XXXXXX. ", +"............. ", +".XXXXXXXXXXX. ", +".XXXXXXXXXXX. ", +".XXXXXXXXXXX. ", +".XXXXXXXXXXX. ", +".XXXXXXXXXXX. ", +".XXXXXXXXXXX. ", +".XXXXXXXXXXX. ", +"............. "}; diff --git a/tix/tests/xpm/f-missline.xpm b/tix/tests/xpm/f-missline.xpm new file mode 100644 index 00000000000..e9f04c0f78c --- /dev/null +++ b/tix/tests/xpm/f-missline.xpm @@ -0,0 +1,19 @@ +/* XPM */ +static char * folder_xpm[] = { +/* width height num_colors chars_per_pixel */ +"16 12 3 1", +/* colors */ +" s None c None", +". c black", +"X c foooo", +/* pixels */ +" .... ", +" .XXXX. ", +" .XXXXXX. ", +".XXXXXXXXXXX. ", +".XXXXXXXXXXX. ", +".XXXXXXXXXXX. ", +".XXXXXXXXXXX. ", +".XXXXXXXXXXX. ", +".XXXXXXXXXXX. ", +"............. "}; diff --git a/tix/tests/xpm/f-ok.xpm b/tix/tests/xpm/f-ok.xpm new file mode 100644 index 00000000000..fda7c15a549 --- /dev/null +++ b/tix/tests/xpm/f-ok.xpm @@ -0,0 +1,21 @@ +/* XPM */ +static char * folder_xpm[] = { +/* width height num_colors chars_per_pixel */ +"16 12 3 1", +/* colors */ +" s None c None", +". c black", +"X c #f0ff80", +/* pixels */ +" .... ", +" .XXXX. ", +" .XXXXXX. ", +"............. ", +".XXXXXXXXXXX. ", +".XXXXXXXXXXX. ", +".XXXXXXXXXXX. ", +".XXXXXXXXXXX. ", +".XXXXXXXXXXX. ", +".XXXXXXXXXXX. ", +".XXXXXXXXXXX. ", +"............. "}; diff --git a/tix/tests/xpm/f-shortln.xpm b/tix/tests/xpm/f-shortln.xpm new file mode 100644 index 00000000000..6a6f8f2ac45 --- /dev/null +++ b/tix/tests/xpm/f-shortln.xpm @@ -0,0 +1,21 @@ +/* XPM */ +static char * folder_xpm[] = { +/* width height num_colors chars_per_pixel */ +"16 12 3 1", +/* colors */ +" s None c None", +". c black", +"X c #f0ff80", +/* pixels */ +" .... ", +" .XXXX. ", +" .XXXXXX. ", +"............. ", +".XXXXXXXXXXX. ", +".XX", +".XXXXXXXXXXX. ", +".XXXXXXXXXXX. ", +".XX. ", +".XX. ", +".XX. ", +"............. "}; diff --git a/tix/tests/xpm/files b/tix/tests/xpm/files new file mode 100644 index 00000000000..73010a9b47e --- /dev/null +++ b/tix/tests/xpm/files @@ -0,0 +1,2 @@ +xpm.tcl +compound.tcl
\ No newline at end of file diff --git a/tix/tests/xpm/folder.xpm b/tix/tests/xpm/folder.xpm new file mode 100644 index 00000000000..fda7c15a549 --- /dev/null +++ b/tix/tests/xpm/folder.xpm @@ -0,0 +1,21 @@ +/* XPM */ +static char * folder_xpm[] = { +/* width height num_colors chars_per_pixel */ +"16 12 3 1", +/* colors */ +" s None c None", +". c black", +"X c #f0ff80", +/* pixels */ +" .... ", +" .XXXX. ", +" .XXXXXX. ", +"............. ", +".XXXXXXXXXXX. ", +".XXXXXXXXXXX. ", +".XXXXXXXXXXX. ", +".XXXXXXXXXXX. ", +".XXXXXXXXXXX. ", +".XXXXXXXXXXX. ", +".XXXXXXXXXXX. ", +"............. "}; diff --git a/tix/tests/xpm/xpm.tcl b/tix/tests/xpm/xpm.tcl new file mode 100644 index 00000000000..f1eee30932c --- /dev/null +++ b/tix/tests/xpm/xpm.tcl @@ -0,0 +1,145 @@ +proc About {} { + return "the pixmap image reader" +} + +proc Test {} { + + set data { +/* XPM */ +static char * folder_xpm[] = { +/* width height num_colors chars_per_pixel */ +"16 12 4 1", +/* colors */ +" s None c None", +". c black", +"X c #f0ff80", +"+ c red", +/* pixels */ +" .... ", +" .XXXX. ", +" .XXXXXX. ", +"............. ", +".XXXXXXXXXXX. ", +".XXXXX+XXXXX. ", +".XXXXX+XXXXX. ", +".XX+++++++XX. ", +".XXXXX+XXXXX. ", +".XXXXX+XXXXX. ", +".XXXXXXXXXXX. ", +"............. "}; + } + +set data1 { +/* XPM */ +static char * news4_xpm[] = { +/* width height ncolors chars_per_pixel */ +"45 34 6 1", +/* colors */ +" s None c None", +". c black", +"X c lemon chiffon", +"o c tan", +"O c blue", +"+ c dark slate grey", +/* pixels */ +" ", +" ", +" . ", +" .X. ", +" ..XX. ", +" .XXX.X. ", +" .XXX.XX. ", +" .XXX.XXXX. ", +" ..XXX.XXX.XX. ", +" .XX...XXX.o..X. ", +" .XX.OO.XX.oooo.X.. ", +" .XXX..O.X.oo..oo..X.. ", +" ..XXX.X..XX..o...oo.XXX. ", +" .XXXX.XXXXX.XX.oo...XXXXX. ", +" .XX..XXXX..XXXX.o.XXXX.XXX. ", +" .X.X.XXXX.XXX.XX..XXX..XXXX. ", +" ..X.XXXXX.XX..XXXXXXX.XXXX.XX. ", +" .X.X.XXX.XX.XXXX.XXX.XXXX.XXX. ", +" .X.X.X.XX.XXXX.XXXXXXX..XXX.. ", +" .X.X.XX.XXX..XX.XXXX.XXX...+ ", +" ++.X.X.XXXX.XXX.XXXX.XXX..++ ", +" ++++.X.X.XX.XX..XXX.XXXX..++ ", +" +++++.X.X.XXX.XXXX.XXX...++ ", +" +++++.X.X.X.XXX..XXX..+++ ", +" +++++.X.X.XXX.XXXX..++ ", +" +++++.X.X.X.XXX...++ ", +" ++++.X.X.XXX..+++ ", +" ++++.X.X.X..++ ", +" +++.XX...++ ", +" ++...+++ ", +" ++++ ", +" ", +" ", +" "}; +} + + + # Test for create + # + # + + # Good pixmap + # + test {set pixmap1 [image create pixmap -file f-ok.xpm]} + + # With some comments + # + test {set pixmap2 [image create pixmap -file f-commt.xpm]} + + # Bad color (should use "black" by default) + # + test {set pixmap3 [image create pixmap -file f-badcol.xpm]} + + # Shortened lines (should show garbage, shouldn't core dump) + # + test {set pixmap4 [image create pixmap -file f-shortln.xpm]} + + # Two chars per pixel + # + test {set pixmap5 [image create pixmap -file 2cpp.xpm]} + + # Bad pixel (should show garbage for undefined pixels) + # + test {set pixmap6 [image create pixmap -file f-badpix.xpm]} + + + # Data switch + # + test {set pixmap7 [image create pixmap -data $data]} + + + # Missing one line + # + test {image create pixmap -file f-missline.xpm} {File For} + + # Multi-word color names + # + test {set pixmap8 [image create pixmap -data $data1]} + + # Brace used as pixel value + # + test {set pixmap9 [image create pixmap -file brace.xpm]} + + # Many /* ... */ comments + # + test {set pixmap10 [image create pixmap -file brace.xpm]} + + set num 10 + for {set i 1} {$i < $num} {incr i} { + button .b$i -image [set pixmap$i] -bg red + pack .b$i + } + + update + + for {set i 1} {$i < $num} {incr i} { + destroy .b$i + image delete [set pixmap$i] + } + +} |