home *** CD-ROM | disk | FTP | other *** search
/ Practical Programming in Tcl & Tk (4th Edition) / TCLBOOK4.BIN / pc / exsource / bindui.tcl < prev    next >
Text File  |  2003-04-15  |  4KB  |  213 lines
  1. #!/bin/sh
  2. # \
  3. exec wish8.4 "$0" ${1+"$@"}
  4.  
  5.  
  6. #
  7. # Example 44-1
  8. # A user interface to widget bindings.
  9. #
  10.  
  11. proc Bind_Interface { w } {
  12.     # Our state
  13.     global bind
  14.     set bind(class) $w
  15.  
  16.     # Set a class used for resource specifications
  17.     set frame [toplevel .bindui -class Bindui]
  18.     # Default relief
  19.     option add *Bindui*Entry.relief sunken startup
  20.     option add *Bindui*Listbox.relief raised startup
  21.     # Default Listbox sizes
  22.     option add *Bindui*key.width 18 startup
  23.     option add *Bindui*cmd.width 25 startup
  24.     option add *Bindui*Listbox.height 5 startup
  25.  
  26.     # A labeled entry at the top to hold the current
  27.     # widget name or class.
  28.     set t [frame $frame.top -bd 2]
  29.     label $t.l -text "Bindings for" -width 11
  30.     entry $t.e -textvariable bind(class)
  31.     pack $t.l -side left
  32.     pack $t.e -side left -fill x -expand true
  33.     pack $t -side top -fill x
  34.     bind $t.e <Return> [list Bind_Display $frame]
  35.  
  36.     # Command buttons
  37.     button $t.quit -text Dismiss \
  38.         -command [list destroy $frame]
  39.     button $t.save -text Save \
  40.         -command [list Bind_Save $frame]
  41.     button $t.edit -text Edit \
  42.         -command [list Bind_Edit $frame]
  43.     button $t.new -text New \
  44.         -command [list Bind_New $frame]
  45.     pack $t.quit $t.save $t.edit $t.new -side right
  46.  
  47.     # A pair of listboxes and a scrollbar
  48.     scrollbar $frame.s -orient vertical \
  49.         -command [list BindYview \
  50.             [list $frame.key $frame.cmd]]
  51.     listbox $frame.key \
  52.         -yscrollcommand [list $frame.s set] \
  53.         -exportselection false
  54.     listbox $frame.cmd \
  55.         -yscrollcommand [list $frame.s set]
  56.     pack $frame.s -side left -fill y
  57.     pack $frame.key $frame.cmd -side left \
  58.         -fill both -expand true
  59.  
  60.     foreach l [list $frame.key $frame.cmd] {
  61.         bind $l <B2-Motion>    \
  62.             [list BindDragto %x %y $frame.key $frame.cmd]
  63.         bind $l <Button-2> \
  64.             [list BindMark %x %y $frame.key $frame.cmd]
  65.         bind $l <Button-1> \
  66.             [list BindSelect %y $frame.key $frame.cmd]
  67.         bind $l <B1-Motion> \
  68.             [list BindSelect %y $frame.key $frame.cmd]
  69.         bind $l <Shift-B1-Motion> {}
  70.         bind $l <Shift-Button-1> {}
  71.     }
  72.     # Initialize the display
  73.     Bind_Display $frame
  74. }
  75.  
  76.  
  77. #
  78. # Example 44-2
  79. # Bind_Display presents the bindings for a widget or class.
  80. #
  81.  
  82. proc Bind_Display { frame } {
  83.     global bind
  84.     $frame.key delete 0 end
  85.     $frame.cmd delete 0 end
  86.     foreach seq [bind $bind(class)] {
  87.         $frame.key insert end $seq
  88.         $frame.cmd insert end [bind $bind(class) $seq]
  89.     }
  90. }
  91.  
  92.  
  93. #
  94. # Example 44-3
  95. # Related listboxes are configured to select items together.
  96. #
  97.  
  98. proc BindSelect { y args } {
  99.     foreach w $args {
  100.         $w select clear 0 end
  101.         $w select anchor [$w nearest $y]
  102.         $w select set anchor [$w nearest $y]
  103.     }
  104. }
  105.  
  106.  
  107. #
  108. # Example 44-4
  109. # Controlling a pair of listboxes with one scrollbar.
  110. #
  111.  
  112. proc BindYview { lists args } {
  113.     foreach l $lists {
  114.         eval {$l yview} $args
  115.     }
  116. }
  117.  
  118.  
  119. #
  120. # Example 44-5
  121. # Drag-scrolling a pair of listboxes together.
  122. #
  123.  
  124. proc BindDragto { x y args } {
  125.     foreach w $args {
  126.         $w scan dragto $x $y
  127.     }
  128. }
  129. proc BindMark { x y args } {
  130.     foreach w $args {
  131.         $w scan mark $x $y
  132.     }
  133. }
  134.  
  135.  
  136. #
  137. # Example 44-6
  138. # An interface to define bindings.
  139. #
  140.  
  141. proc Bind_New { frame } {
  142.     if [catch {frame $frame.edit} f] {
  143.         # Frame already created
  144.         set f $frame.edit
  145.     } else {
  146.         foreach x {key cmd} {
  147.             set f2 [frame $f.$x]
  148.             pack $f2 -fill x -padx 2
  149.             label $f2.l -width 11 -anchor e
  150.             pack $f2.l -side left
  151.             entry $f2.e
  152.             pack $f2.e -side left -fill x -expand true
  153.             bind $f2.e <Return> [list BindDefine $f]
  154.         }
  155.         $f.key.l config -text Event:
  156.         $f.cmd.l config -text Command:
  157.     }
  158.     pack $frame.edit -after $frame.top -fill x
  159. }
  160. proc Bind_Edit { frame } {
  161.     Bind_New $frame
  162.     set line [$frame.key curselection]
  163.     if {$line == {}} {
  164.         return
  165.     }
  166.     $frame.edit.key.e delete 0 end
  167.     $frame.edit.key.e insert 0 [$frame.key get $line]
  168.     $frame.edit.cmd.e delete 0 end
  169.     $frame.edit.cmd.e insert 0 [$frame.cmd get $line]
  170. }
  171.  
  172.  
  173. #
  174. # Example 44-7
  175. # Defining and saving bindings.
  176. #
  177.  
  178. proc BindDefine { f } {
  179.     if [catch {
  180.         bind [$f.top.e get] [$f.edit.key.e get] \
  181.             [$f.edit.cmd.e get]
  182.     } err] {
  183.         Status $err
  184.     } else {
  185.         # Remove the edit window
  186.         pack forget $f.edit
  187.     }
  188. }
  189. proc Bind_Save { dotfile args } {
  190.     set out [open $dotfile.new w]
  191.     foreach w $args {
  192.         foreach seq [bind $w] {
  193.             # Output a Tcl command
  194.             puts $out [list bind $w $seq [bind $w $seq]]
  195.         }
  196.     }
  197.     close $out
  198.     file rename -force $dotfile.new $dotfile
  199. }
  200. proc Bind_Read { dotfile } {
  201.     if [catch {
  202.         if [file exists $dotfile] {
  203.             # Read the saved Tcl commands
  204.             source $dotfile
  205.         }
  206.     } err] {
  207.         Status "Bind_Read $dotfile failed: $err"
  208.     }
  209. }
  210.  
  211.  
  212. Bind_Interface Text
  213.