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