archie/tk4.2/tests/visual
2024-05-27 16:40:40 +02:00

81 lines
3.0 KiB
Tcl

#!/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.
#
# SCCS: @(#) visual 1.3 96/02/16 10:55:47
set auto_path ". $auto_path"
wm title . "Visual Tests for Tk"
#-------------------------------------------------------
# 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 -Adobe-times-medium-r-normal--*-180-*-*-*-*-*-* \
-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 exit
menubutton .menu.group1 -text "Group 1" -menu .menu.group1.m
menu .menu.group1.m
.menu.group1.m add command -label "Canvas arcs" -command {source arc.tcl}
.menu.group1.m add command -label "Beveled borders in text widgets" \
-command {source bevel.tcl}
.menu.group1.m add command -label "Colormap management" \
-command {source cmap.tcl}
.menu.group1.m add command -label "Label/button geometry" \
-command {source butGeom.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 {source canvPsGrph.tcl}
.menu.ps.m add command -label "Text" \
-command {source canvPsText.tcl}
.menu.ps.m add command -label "Bitmaps" \
-command {source canvPsBmap.tcl}
.menu.ps.m add command -label "Arcs" \
-command {source 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
# 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
}
# 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]}