[37] | 1 | # tk.tcl -- |
---|
| 2 | # |
---|
| 3 | # Initialization script normally executed in the interpreter for each |
---|
| 4 | # Tk-based application. Arranges class bindings for widgets. |
---|
| 5 | # |
---|
| 6 | # RCS: @(#) $Id: tk.tcl,v 1.20 2000/03/24 19:38:57 ericm Exp $ |
---|
| 7 | # |
---|
| 8 | # Copyright (c) 1992-1994 The Regents of the University of California. |
---|
| 9 | # Copyright (c) 1994-1996 Sun Microsystems, Inc. |
---|
| 10 | # Copyright (c) 1998-2000 Scriptics Corporation. |
---|
| 11 | # |
---|
| 12 | # See the file "license.terms" for information on usage and redistribution |
---|
| 13 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
---|
| 14 | |
---|
| 15 | # Insist on running with compatible versions of Tcl and Tk. |
---|
| 16 | |
---|
| 17 | package require -exact Tk 8.3 |
---|
| 18 | package require -exact Tcl 8.3 |
---|
| 19 | |
---|
| 20 | # Add Tk's directory to the end of the auto-load search path, if it |
---|
| 21 | # isn't already on the path: |
---|
| 22 | |
---|
| 23 | if {[info exists auto_path] && [string compare {} $tk_library] && \ |
---|
| 24 | [lsearch -exact $auto_path $tk_library] < 0} { |
---|
| 25 | lappend auto_path $tk_library |
---|
| 26 | } |
---|
| 27 | |
---|
| 28 | # Turn off strict Motif look and feel as a default. |
---|
| 29 | |
---|
| 30 | set tk_strictMotif 0 |
---|
| 31 | |
---|
| 32 | # Create a ::tk namespace |
---|
| 33 | |
---|
| 34 | namespace eval ::tk { |
---|
| 35 | } |
---|
| 36 | |
---|
| 37 | # ::tk::PlaceWindow -- |
---|
| 38 | # place a toplevel at a particular position |
---|
| 39 | # Arguments: |
---|
| 40 | # toplevel name of toplevel window |
---|
| 41 | # ?placement? pointer ?center? ; places $w centered on the pointer |
---|
| 42 | # widget widgetPath ; centers $w over widget_name |
---|
| 43 | # defaults to placing toplevel in the middle of the screen |
---|
| 44 | # ?anchor? center or widgetPath |
---|
| 45 | # Results: |
---|
| 46 | # Returns nothing |
---|
| 47 | # |
---|
| 48 | proc ::tk::PlaceWindow {w {place ""} {anchor ""}} { |
---|
| 49 | wm withdraw $w |
---|
| 50 | update idletasks |
---|
| 51 | set checkBounds 1 |
---|
| 52 | if {[string equal -len [string length $place] $place "pointer"]} { |
---|
| 53 | ## place at POINTER (centered if $anchor == center) |
---|
| 54 | if {[string equal -len [string length $anchor] $anchor "center"]} { |
---|
| 55 | set x [expr {[winfo pointerx $w]-[winfo reqwidth $w]/2}] |
---|
| 56 | set y [expr {[winfo pointery $w]-[winfo reqheight $w]/2}] |
---|
| 57 | } else { |
---|
| 58 | set x [winfo pointerx $w] |
---|
| 59 | set y [winfo pointery $w] |
---|
| 60 | } |
---|
| 61 | } elseif {[string equal -len [string length $place] $place "widget"] && \ |
---|
| 62 | [winfo exists $anchor] && [winfo ismapped $anchor]} { |
---|
| 63 | ## center about WIDGET $anchor, widget must be mapped |
---|
| 64 | set x [expr {[winfo rootx $anchor] + \ |
---|
| 65 | ([winfo width $anchor]-[winfo reqwidth $w])/2}] |
---|
| 66 | set y [expr {[winfo rooty $anchor] + \ |
---|
| 67 | ([winfo height $anchor]-[winfo reqheight $w])/2}] |
---|
| 68 | } else { |
---|
| 69 | set x [expr {([winfo screenwidth $w]-[winfo reqwidth $w])/2}] |
---|
| 70 | set y [expr {([winfo screenheight $w]-[winfo reqheight $w])/2}] |
---|
| 71 | set checkBounds 0 |
---|
| 72 | } |
---|
| 73 | if {$checkBounds} { |
---|
| 74 | if {$x < 0} { |
---|
| 75 | set x 0 |
---|
| 76 | } elseif {$x > ([winfo screenwidth $w]-[winfo reqwidth $w])} { |
---|
| 77 | set x [expr {[winfo screenwidth $w]-[winfo reqwidth $w]}] |
---|
| 78 | } |
---|
| 79 | if {$y < 0} { |
---|
| 80 | set y 0 |
---|
| 81 | } elseif {$y > ([winfo screenheight $w]-[winfo reqheight $w])} { |
---|
| 82 | set y [expr {[winfo screenheight $w]-[winfo reqheight $w]}] |
---|
| 83 | } |
---|
| 84 | } |
---|
| 85 | wm geometry $w +$x+$y |
---|
| 86 | wm deiconify $w |
---|
| 87 | } |
---|
| 88 | |
---|
| 89 | # ::tk::SetFocusGrab -- |
---|
| 90 | # swap out current focus and grab temporarily (for dialogs) |
---|
| 91 | # Arguments: |
---|
| 92 | # grab new window to grab |
---|
| 93 | # focus window to give focus to |
---|
| 94 | # Results: |
---|
| 95 | # Returns nothing |
---|
| 96 | # |
---|
| 97 | proc ::tk::SetFocusGrab {grab {focus {}}} { |
---|
| 98 | set index "$grab,$focus" |
---|
| 99 | upvar ::tk::FocusGrab($index) data |
---|
| 100 | |
---|
| 101 | lappend data [focus] |
---|
| 102 | set oldGrab [grab current $grab] |
---|
| 103 | lappend data $oldGrab |
---|
| 104 | if {[winfo exists $oldGrab]} { |
---|
| 105 | lappend data [grab status $oldGrab] |
---|
| 106 | } |
---|
| 107 | grab $grab |
---|
| 108 | if {[winfo exists $focus]} { |
---|
| 109 | focus $focus |
---|
| 110 | } |
---|
| 111 | } |
---|
| 112 | |
---|
| 113 | # ::tk::RestoreFocusGrab -- |
---|
| 114 | # restore old focus and grab (for dialogs) |
---|
| 115 | # Arguments: |
---|
| 116 | # grab window that had taken grab |
---|
| 117 | # focus window that had taken focus |
---|
| 118 | # destroy destroy|withdraw - how to handle the old grabbed window |
---|
| 119 | # Results: |
---|
| 120 | # Returns nothing |
---|
| 121 | # |
---|
| 122 | proc ::tk::RestoreFocusGrab {grab focus {destroy destroy}} { |
---|
| 123 | set index "$grab,$focus" |
---|
| 124 | foreach {oldFocus oldGrab oldStatus} $::tk::FocusGrab($index) { break } |
---|
| 125 | unset ::tk::FocusGrab($index) |
---|
| 126 | |
---|
| 127 | catch {focus $oldFocus} |
---|
| 128 | grab release $grab |
---|
| 129 | if {[string equal $destroy "withdraw"]} { |
---|
| 130 | wm withdraw $grab |
---|
| 131 | } else { |
---|
| 132 | destroy $grab |
---|
| 133 | } |
---|
| 134 | if {[winfo exists $oldGrab] && [winfo ismapped $oldGrab]} { |
---|
| 135 | if {[string equal $oldStatus "global"]} { |
---|
| 136 | grab -global $oldGrab |
---|
| 137 | } else { |
---|
| 138 | grab $oldGrab |
---|
| 139 | } |
---|
| 140 | } |
---|
| 141 | } |
---|
| 142 | |
---|
| 143 | # tkScreenChanged -- |
---|
| 144 | # This procedure is invoked by the binding mechanism whenever the |
---|
| 145 | # "current" screen is changing. The procedure does two things. |
---|
| 146 | # First, it uses "upvar" to make global variable "tkPriv" point at an |
---|
| 147 | # array variable that holds state for the current display. Second, |
---|
| 148 | # it initializes the array if it didn't already exist. |
---|
| 149 | # |
---|
| 150 | # Arguments: |
---|
| 151 | # screen - The name of the new screen. |
---|
| 152 | |
---|
| 153 | proc tkScreenChanged screen { |
---|
| 154 | set x [string last . $screen] |
---|
| 155 | if {$x > 0} { |
---|
| 156 | set disp [string range $screen 0 [expr {$x - 1}]] |
---|
| 157 | } else { |
---|
| 158 | set disp $screen |
---|
| 159 | } |
---|
| 160 | |
---|
| 161 | uplevel #0 upvar #0 tkPriv.$disp tkPriv |
---|
| 162 | global tkPriv |
---|
| 163 | global tcl_platform |
---|
| 164 | |
---|
| 165 | if {[info exists tkPriv]} { |
---|
| 166 | set tkPriv(screen) $screen |
---|
| 167 | return |
---|
| 168 | } |
---|
| 169 | array set tkPriv { |
---|
| 170 | activeMenu {} |
---|
| 171 | activeItem {} |
---|
| 172 | afterId {} |
---|
| 173 | buttons 0 |
---|
| 174 | buttonWindow {} |
---|
| 175 | dragging 0 |
---|
| 176 | focus {} |
---|
| 177 | grab {} |
---|
| 178 | initPos {} |
---|
| 179 | inMenubutton {} |
---|
| 180 | listboxPrev {} |
---|
| 181 | menuBar {} |
---|
| 182 | mouseMoved 0 |
---|
| 183 | oldGrab {} |
---|
| 184 | popup {} |
---|
| 185 | postedMb {} |
---|
| 186 | pressX 0 |
---|
| 187 | pressY 0 |
---|
| 188 | prevPos 0 |
---|
| 189 | selectMode char |
---|
| 190 | } |
---|
| 191 | set tkPriv(screen) $screen |
---|
| 192 | set tkPriv(tearoff) [string equal $tcl_platform(platform) "unix"] |
---|
| 193 | set tkPriv(window) {} |
---|
| 194 | } |
---|
| 195 | |
---|
| 196 | # Do initial setup for tkPriv, so that it is always bound to something |
---|
| 197 | # (otherwise, if someone references it, it may get set to a non-upvar-ed |
---|
| 198 | # value, which will cause trouble later). |
---|
| 199 | |
---|
| 200 | tkScreenChanged [winfo screen .] |
---|
| 201 | |
---|
| 202 | # tkEventMotifBindings -- |
---|
| 203 | # This procedure is invoked as a trace whenever tk_strictMotif is |
---|
| 204 | # changed. It is used to turn on or turn off the motif virtual |
---|
| 205 | # bindings. |
---|
| 206 | # |
---|
| 207 | # Arguments: |
---|
| 208 | # n1 - the name of the variable being changed ("tk_strictMotif"). |
---|
| 209 | |
---|
| 210 | proc tkEventMotifBindings {n1 dummy dummy} { |
---|
| 211 | upvar $n1 name |
---|
| 212 | |
---|
| 213 | if {$name} { |
---|
| 214 | set op delete |
---|
| 215 | } else { |
---|
| 216 | set op add |
---|
| 217 | } |
---|
| 218 | |
---|
| 219 | event $op <<Cut>> <Control-Key-w> |
---|
| 220 | event $op <<Copy>> <Meta-Key-w> |
---|
| 221 | event $op <<Paste>> <Control-Key-y> |
---|
| 222 | } |
---|
| 223 | |
---|
| 224 | #---------------------------------------------------------------------- |
---|
| 225 | # Define common dialogs on platforms where they are not implemented |
---|
| 226 | # using compiled code. |
---|
| 227 | #---------------------------------------------------------------------- |
---|
| 228 | |
---|
| 229 | if {[string equal [info commands tk_chooseColor] ""]} { |
---|
| 230 | proc tk_chooseColor {args} { |
---|
| 231 | return [eval tkColorDialog $args] |
---|
| 232 | } |
---|
| 233 | } |
---|
| 234 | if {[string equal [info commands tk_getOpenFile] ""]} { |
---|
| 235 | proc tk_getOpenFile {args} { |
---|
| 236 | if {$::tk_strictMotif} { |
---|
| 237 | return [eval tkMotifFDialog open $args] |
---|
| 238 | } else { |
---|
| 239 | return [eval ::tk::dialog::file::tkFDialog open $args] |
---|
| 240 | } |
---|
| 241 | } |
---|
| 242 | } |
---|
| 243 | if {[string equal [info commands tk_getSaveFile] ""]} { |
---|
| 244 | proc tk_getSaveFile {args} { |
---|
| 245 | if {$::tk_strictMotif} { |
---|
| 246 | return [eval tkMotifFDialog save $args] |
---|
| 247 | } else { |
---|
| 248 | return [eval ::tk::dialog::file::tkFDialog save $args] |
---|
| 249 | } |
---|
| 250 | } |
---|
| 251 | } |
---|
| 252 | if {[string equal [info commands tk_messageBox] ""]} { |
---|
| 253 | proc tk_messageBox {args} { |
---|
| 254 | return [eval tkMessageBox $args] |
---|
| 255 | } |
---|
| 256 | } |
---|
| 257 | if {[string equal [info command tk_chooseDirectory] ""]} { |
---|
| 258 | proc tk_chooseDirectory {args} { |
---|
| 259 | return [eval ::tk::dialog::file::chooseDir::tkChooseDirectory $args] |
---|
| 260 | } |
---|
| 261 | } |
---|
| 262 | |
---|
| 263 | #---------------------------------------------------------------------- |
---|
| 264 | # Define the set of common virtual events. |
---|
| 265 | #---------------------------------------------------------------------- |
---|
| 266 | |
---|
| 267 | switch $tcl_platform(platform) { |
---|
| 268 | "unix" { |
---|
| 269 | event add <<Cut>> <Control-Key-x> <Key-F20> |
---|
| 270 | event add <<Copy>> <Control-Key-c> <Key-F16> |
---|
| 271 | event add <<Paste>> <Control-Key-v> <Key-F18> |
---|
| 272 | event add <<PasteSelection>> <ButtonRelease-2> |
---|
| 273 | # Some OS's define a goofy (as in, not <Shift-Tab>) keysym |
---|
| 274 | # that is returned when the user presses <Shift-Tab>. In order for |
---|
| 275 | # tab traversal to work, we have to add these keysyms to the |
---|
| 276 | # PrevWindow event. |
---|
| 277 | # The info exists is necessary, because tcl_platform(os) doesn't |
---|
| 278 | # exist in safe interpreters. |
---|
| 279 | if {[info exists tcl_platform(os)]} { |
---|
| 280 | switch $tcl_platform(os) { |
---|
| 281 | "IRIX" - |
---|
| 282 | "Linux" { event add <<PrevWindow>> <ISO_Left_Tab> } |
---|
| 283 | "HP-UX" { event add <<PrevWindow>> <hpBackTab> } |
---|
| 284 | } |
---|
| 285 | } |
---|
| 286 | trace variable tk_strictMotif w tkEventMotifBindings |
---|
| 287 | set tk_strictMotif $tk_strictMotif |
---|
| 288 | } |
---|
| 289 | "windows" { |
---|
| 290 | event add <<Cut>> <Control-Key-x> <Shift-Key-Delete> |
---|
| 291 | event add <<Copy>> <Control-Key-c> <Control-Key-Insert> |
---|
| 292 | event add <<Paste>> <Control-Key-v> <Shift-Key-Insert> |
---|
| 293 | event add <<PasteSelection>> <ButtonRelease-2> |
---|
| 294 | } |
---|
| 295 | "macintosh" { |
---|
| 296 | event add <<Cut>> <Control-Key-x> <Key-F2> |
---|
| 297 | event add <<Copy>> <Control-Key-c> <Key-F3> |
---|
| 298 | event add <<Paste>> <Control-Key-v> <Key-F4> |
---|
| 299 | event add <<PasteSelection>> <ButtonRelease-2> |
---|
| 300 | event add <<Clear>> <Clear> |
---|
| 301 | } |
---|
| 302 | } |
---|
| 303 | |
---|
| 304 | # ---------------------------------------------------------------------- |
---|
| 305 | # Read in files that define all of the class bindings. |
---|
| 306 | # ---------------------------------------------------------------------- |
---|
| 307 | |
---|
| 308 | if {[string compare $tcl_platform(platform) "macintosh"] && \ |
---|
| 309 | [string compare {} $tk_library]} { |
---|
| 310 | source [file join $tk_library button.tcl] |
---|
| 311 | source [file join $tk_library entry.tcl] |
---|
| 312 | source [file join $tk_library listbox.tcl] |
---|
| 313 | source [file join $tk_library menu.tcl] |
---|
| 314 | source [file join $tk_library scale.tcl] |
---|
| 315 | source [file join $tk_library scrlbar.tcl] |
---|
| 316 | source [file join $tk_library text.tcl] |
---|
| 317 | } |
---|
| 318 | |
---|
| 319 | # ---------------------------------------------------------------------- |
---|
| 320 | # Default bindings for keyboard traversal. |
---|
| 321 | # ---------------------------------------------------------------------- |
---|
| 322 | |
---|
| 323 | event add <<PrevWindow>> <Shift-Tab> |
---|
| 324 | bind all <Tab> {tkTabToWindow [tk_focusNext %W]} |
---|
| 325 | bind all <<PrevWindow>> {tkTabToWindow [tk_focusPrev %W]} |
---|
| 326 | |
---|
| 327 | # tkCancelRepeat -- |
---|
| 328 | # This procedure is invoked to cancel an auto-repeat action described |
---|
| 329 | # by tkPriv(afterId). It's used by several widgets to auto-scroll |
---|
| 330 | # the widget when the mouse is dragged out of the widget with a |
---|
| 331 | # button pressed. |
---|
| 332 | # |
---|
| 333 | # Arguments: |
---|
| 334 | # None. |
---|
| 335 | |
---|
| 336 | proc tkCancelRepeat {} { |
---|
| 337 | global tkPriv |
---|
| 338 | after cancel $tkPriv(afterId) |
---|
| 339 | set tkPriv(afterId) {} |
---|
| 340 | } |
---|
| 341 | |
---|
| 342 | # tkTabToWindow -- |
---|
| 343 | # This procedure moves the focus to the given widget. If the widget |
---|
| 344 | # is an entry, it selects the entire contents of the widget. |
---|
| 345 | # |
---|
| 346 | # Arguments: |
---|
| 347 | # w - Window to which focus should be set. |
---|
| 348 | |
---|
| 349 | proc tkTabToWindow {w} { |
---|
| 350 | if {[string equal [winfo class $w] Entry]} { |
---|
| 351 | $w selection range 0 end |
---|
| 352 | $w icursor end |
---|
| 353 | } |
---|
| 354 | focus $w |
---|
| 355 | } |
---|