tk/tests/visual

   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
  11 set auto_path ". $auto_path"
  12 wm title . "Visual Tests for Tk"
  13
  14 #-------------------------------------------------------
  15 # The code below create the main window, consisting of a
  16 # menu bar and a message explaining the basic operation
  17 # of the program.
  18 #-------------------------------------------------------
  19
  20 frame .menu -relief raised -borderwidth 1
  21 message .msg -font {Times 18} -relief raised -width 4i \
  22         -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."
  23
  24 pack .menu -side top -fill x
  25 pack .msg -side bottom -expand yes -fill both
  26
  27 #-------------------------------------------------------
  28 # The code below creates all the menus, which invoke procedures
  29 # to create particular demonstrations of various widgets.
  30 #-------------------------------------------------------
  31
  32 menubutton .menu.file -text "File" -menu .menu.file.m
  33 menu .menu.file.m
  34 .menu.file.m add command -label "Quit" -command exit
  35
  36 menubutton .menu.group1 -text "Group 1" -menu .menu.group1.m
  37 menu .menu.group1.m
  38 .menu.group1.m add command -label "Canvas arcs" -command {source arc.tcl}
  39 .menu.group1.m add command -label "Beveled borders in text widgets" \
  40         -command {source bevel.tcl}
  41 .menu.group1.m add command -label "Colormap management" \
  42         -command {source cmap.tcl}
  43 .menu.group1.m add command -label "Label/button geometry" \
  44         -command {source butGeom.tcl}
  45 .menu.group1.m add command -label "Label/button colors" \
  46         -command {source butGeom2.tcl}
  47
  48 menubutton .menu.ps -text "Canvas Postscript" -menu .menu.ps.m
  49 menu .menu.ps.m
  50 .menu.ps.m add command -label "Rectangles and other graphics" \
  51         -command {source canvPsGrph.tcl}
  52 .menu.ps.m add command -label "Text" \
  53         -command {source canvPsText.tcl}
  54 .menu.ps.m add command -label "Bitmaps" \
  55         -command {source canvPsBmap.tcl}
  56 .menu.ps.m add command -label "Arcs" \
  57         -command {source canvPsArc.tcl}
  58
  59 pack .menu.file .menu.group1 .menu.ps -side left -padx 1m
  60
  61 # Set up for keyboard-based menu traversal
  62
  63 bind . <Any-FocusIn> {
  64     if {("%d" == "NotifyVirtual") && ("%m" == "NotifyNormal")} {
  65         focus .menu
  66     }
  67 }
  68 tk_menuBar .menu .menu.file .menu.group1 .menu.ps
  69
  70 # The following procedure is invoked to print the contents of a canvas:
  71
  72 proc lpr c {
  73     exec rm -f tmp.ps
  74     $c postscript -file tmp.ps
  75     exec lpr tmp.ps
  76 }
  77
  78 # Set up a class binding to allow objects to be deleted from a canvas
  79 # by clicking with mouse button 1:
  80
  81 bind Canvas <1> {%W delete [%W find closest %x %y]}