util/src/TclTk/tk8.6.12/tests/visual_bb.test

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