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