diff options
Diffstat (limited to 'tests/visual_bb.test')
| -rw-r--r-- | tests/visual_bb.test | 109 |
1 files changed, 109 insertions, 0 deletions
diff --git a/tests/visual_bb.test b/tests/visual_bb.test new file mode 100644 index 0000000..efafc09 --- /dev/null +++ b/tests/visual_bb.test @@ -0,0 +1,109 @@ +#!/usr/local/bin/wish -f +# +# This script displays provides visual tests for many of Tk's features. +# Each test displays a window with various information in it, along +# with instructions about how the window should appear. You can look +# at the window to make sure it appears as expected. Individual tests +# are kept in separate ".tcl" files in this directory. +# +# RCS: @(#) $Id: visual_bb.test,v 1.2 1999/04/16 01:51:43 stanton Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + +set auto_path ". $auto_path" +wm title . "Visual Tests for Tk" + +set testNum 1 + +# Each menu entry invokes a visual test file + +proc runTest {file} { + global testNum + + test "2.$testNum" "testing $file" {userInteraction} { + uplevel \#0 source [file join $::tcltest::testsDir $file] + concat "" + } {} + incr testNum +} + +# The following procedure is invoked to print the contents of a canvas: + +proc lpr c { + exec rm -f tmp.ps + $c postscript -file tmp.ps + exec lpr tmp.ps + exec rm -f tmp.ps +} + +test 1.1 "running visual tests" {userInteraction} { + + #------------------------------------------------------- + # The code below create the main window, consisting of a + # menu bar and a message explaining the basic operation + # of the program. + #------------------------------------------------------- + + frame .menu -relief raised -borderwidth 1 + message .msg -font {Times 18} -relief raised -width 4i \ + -borderwidth 1 -text "This application provides a collection of visual tests for the Tk toolkit. Each menu entry invokes a test, which displays information on the screen. You can then verify visually that the information is being displayed in the correct way. The tests under the \"Postscript\" menu exercise the Postscript-generation capabilities of canvas widgets." + + pack .menu -side top -fill x + pack .msg -side bottom -expand yes -fill both + + #------------------------------------------------------- + # The code below creates all the menus, which invoke procedures + # to create particular demonstrations of various widgets. + #------------------------------------------------------- + + menubutton .menu.file -text "File" -menu .menu.file.m + menu .menu.file.m + .menu.file.m add command -label "Quit" -command ::tcltest::cleanupTests + + menubutton .menu.group1 -text "Group 1" -menu .menu.group1.m + menu .menu.group1.m + .menu.group1.m add command -label "Canvas arcs" -command {runTest arc.tcl} + .menu.group1.m add command -label "Beveled borders in text widgets" \ + -command {runTest bevel.tcl} + .menu.group1.m add command -label "Colormap management" \ + -command {runTest cmap.tcl} + .menu.group1.m add command -label "Label/button geometry" \ + -command {runTest butGeom.tcl} + .menu.group1.m add command -label "Label/button colors" \ + -command {runTest butGeom2.tcl} + + menubutton .menu.ps -text "Canvas Postscript" -menu .menu.ps.m + menu .menu.ps.m + .menu.ps.m add command -label "Rectangles and other graphics" \ + -command {runTest canvPsGrph.tcl} + .menu.ps.m add command -label "Text" \ + -command {runTest canvPsText.tcl} + .menu.ps.m add command -label "Bitmaps" \ + -command {runTest canvPsBmap.tcl} + .menu.ps.m add command -label "Arcs" \ + -command {runTest canvPsArc.tcl} + + pack .menu.file .menu.group1 .menu.ps -side left -padx 1m + + # Set up for keyboard-based menu traversal + + bind . <Any-FocusIn> { + if {("%d" == "NotifyVirtual") && ("%m" == "NotifyNormal")} { + focus .menu + } + } + tk_menuBar .menu .menu.file .menu.group1 .menu.ps + + # Set up a class binding to allow objects to be deleted from a canvas + # by clicking with mouse button 1: + + bind Canvas <1> {%W delete [%W find closest %x %y]} + + concat "" +} {} + +if {!$::tcltest::testConfig(userInteraction)} { + ::tcltest::cleanupTests +} |