1#!/usr/local/bin/wish -f 2# 3# This script displays provides visual tests for many of Tk's features. 4# Each test displays a window with various information in it, along 5# with instructions about how the window should appear. You can look 6# at the window to make sure it appears as expected. Individual tests 7# are kept in separate ".tcl" files in this directory. 8# 9# RCS: @(#) $Id$ 10 11package require tcltest 2.1 12eval tcltest::configure $argv 13tcltest::loadTestedCommands 14 15set auto_path ". $auto_path" 16wm title . "Visual Tests for Tk" 17 18set testNum 1 19 20# Each menu entry invokes a visual test file 21 22proc runTest {file} { 23 global testNum 24 25 test "2.$testNum" "testing $file" {userInteraction} { 26 uplevel \#0 source [file join [testsDirectory] $file] 27 concat "" 28 } {} 29 incr testNum 30} 31 32# The following procedure is invoked to print the contents of a canvas: 33 34proc lpr {c args} { 35 exec lpr <<[eval [list $c postscript] $args] 36} 37 38proc end {} { 39 cleanupTests 40 set ::EndOfVisualTests 1 41} 42 43test 1.1 "running visual tests" {userInteraction} { 44 #------------------------------------------------------- 45 # The code below create the main window, consisting of a 46 # menu bar and a message explaining the basic operation 47 # of the program. 48 #------------------------------------------------------- 49 50 frame .menu -relief raised -borderwidth 1 51 message .msg -font {Times 18} -relief raised -width 4i \ 52 -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." 53 54 pack .menu -side top -fill x 55 pack .msg -side bottom -expand yes -fill both 56 57 #------------------------------------------------------- 58 # The code below creates all the menus, which invoke procedures 59 # to create particular demonstrations of various widgets. 60 #------------------------------------------------------- 61 62 menubutton .menu.file -text "File" -menu .menu.file.m 63 menu .menu.file.m 64 .menu.file.m add command -label "Quit" -command end 65 66 menubutton .menu.group1 -text "Group 1" -menu .menu.group1.m 67 menu .menu.group1.m 68 .menu.group1.m add command -label "Canvas arcs" -command {runTest arc.tcl} 69 .menu.group1.m add command -label "Beveled borders in text widgets" \ 70 -command {runTest bevel.tcl} 71 .menu.group1.m add command -label "Colormap management" \ 72 -command {runTest cmap.tcl} 73 .menu.group1.m add command -label "Label/button geometry" \ 74 -command {runTest butGeom.tcl} 75 .menu.group1.m add command -label "Label/button colors" \ 76 -command {runTest butGeom2.tcl} 77 78 menubutton .menu.ps -text "Canvas Postscript" -menu .menu.ps.m 79 menu .menu.ps.m 80 .menu.ps.m add command -label "Rectangles and other graphics" \ 81 -command {runTest canvPsGrph.tcl} 82 .menu.ps.m add command -label "Text" \ 83 -command {runTest canvPsText.tcl} 84 .menu.ps.m add command -label "Bitmaps" \ 85 -command {runTest canvPsBmap.tcl} 86 .menu.ps.m add command -label "Images" \ 87 -command {runTest canvPsImg.tcl} 88 .menu.ps.m add command -label "Arcs" \ 89 -command {runTest canvPsArc.tcl} 90 91 pack .menu.file .menu.group1 .menu.ps -side left -padx 1m 92 93 # Set up for keyboard-based menu traversal 94 95 bind . <Any-FocusIn> { 96 if {("%d" == "NotifyVirtual") && ("%m" == "NotifyNormal")} { 97 focus .menu 98 } 99 } 100 tk_menuBar .menu .menu.file .menu.group1 .menu.ps 101 102 # Set up a class binding to allow objects to be deleted from a canvas 103 # by clicking with mouse button 1: 104 105 bind Canvas <1> {%W delete [%W find closest %x %y]} 106 107 concat "" 108} {} 109 110if {![testConstraint userInteraction]} { 111 cleanupTests 112} else { 113 vwait EndOfVisualTests 114} 115