mingw/lib/tk8.5/tk.tcl

   1 # tk.tcl --
   2 #
   3 # Initialization script normally executed in the interpreter for each Tk-based
   4 # application.  Arranges class bindings for widgets.
   5 #
   6 # Copyright (c) 1992-1994 The Regents of the University of California.
   7 # Copyright (c) 1994-1996 Sun Microsystems, Inc.
   8 # Copyright (c) 1998-2000 Ajuba Solutions.
   9 #
  10 # See the file "license.terms" for information on usage and redistribution of
  11 # this file, and for a DISCLAIMER OF ALL WARRANTIES.
  12
  13 package require Tcl 8.5 ;# Guard against [source] in an 8.4- interp before
  14                         ;# using 8.5 [package] features.
  15 # Insist on running with compatible version of Tcl
  16 package require Tcl 8.5.0
  17 # Verify that we have Tk binary and script components from the same release
  18 package require -exact Tk  8.5.11
  19
  20 # Create a ::tk namespace
  21 namespace eval ::tk {
  22     # Set up the msgcat commands
  23     namespace eval msgcat {
  24         namespace export mc mcmax
  25         if {[interp issafe] || [catch {package require msgcat}]} {
  26             # The msgcat package is not available.  Supply our own minimal
  27             # replacement.
  28             proc mc {src args} {
  29                 return [format $src {*}$args]
  30             }
  31             proc mcmax {args} {
  32                 set max 0
  33                 foreach string $args {
  34                     set len [string length $string]
  35                     if {$len>$max} {
  36                         set max $len
  37                     }
  38                 }
  39                 return $max
  40             }
  41         } else {
  42             # Get the commands from the msgcat package that Tk uses.
  43             namespace import ::msgcat::mc
  44             namespace import ::msgcat::mcmax
  45             ::msgcat::mcload [file join $::tk_library msgs]
  46         }
  47     }
  48     namespace import ::tk::msgcat::*
  49 }
  50 # and a ::ttk namespace
  51 namespace eval ::ttk {
  52     if {$::tk_library ne ""} {
  53         # avoid file join to work in safe interps, but this is also x-plat ok
  54         variable library $::tk_library/ttk
  55     }
  56 }
  57
  58 # Add Ttk & Tk's directory to the end of the auto-load search path, if it
  59 # isn't already on the path:
  60
  61 if {[info exists ::auto_path] && ($::tk_library ne "")
  62     && ($::tk_library ni $::auto_path)} {
  63     lappend ::auto_path $::tk_library $::ttk::library
  64 }
  65
  66 # Turn off strict Motif look and feel as a default.
  67
  68 set ::tk_strictMotif 0
  69
  70 # Turn on useinputmethods (X Input Methods) by default. We catch this because
  71 # safe interpreters may not allow the call.
  72
  73 catch {tk useinputmethods 1}
  74 \f
  75 # ::tk::PlaceWindow --
  76 #   Place a toplevel at a particular position
  77 # Arguments:
  78 #   toplevel    name of toplevel window
  79 #   ?placement? pointer ?center? ; places $w centered on the pointer
  80 #               widget widgetPath ; centers $w over widget_name
  81 #               defaults to placing toplevel in the middle of the screen
  82 #   ?anchor?    center or widgetPath
  83 # Results:
  84 #   Returns nothing
  85 #
  86 proc ::tk::PlaceWindow {w {place ""} {anchor ""}} {
  87     wm withdraw $w
  88     update idletasks
  89     set checkBounds 1
  90     if {$place eq ""} {
  91         set x [expr {([winfo screenwidth $w]-[winfo reqwidth $w])/2}]
  92         set y [expr {([winfo screenheight $w]-[winfo reqheight $w])/2}]
  93         set checkBounds 0
  94     } elseif {[string equal -length [string length $place] $place "pointer"]} {
  95         ## place at POINTER (centered if $anchor == center)
  96         if {[string equal -length [string length $anchor] $anchor "center"]} {
  97             set x [expr {[winfo pointerx $w]-[winfo reqwidth $w]/2}]
  98             set y [expr {[winfo pointery $w]-[winfo reqheight $w]/2}]
  99         } else {
 100             set x [winfo pointerx $w]
 101             set y [winfo pointery $w]
 102         }
 103     } elseif {[string equal -length [string length $place] $place "widget"] && \
 104             [winfo exists $anchor] && [winfo ismapped $anchor]} {
 105         ## center about WIDGET $anchor, widget must be mapped
 106         set x [expr {[winfo rootx $anchor] + \
 107                 ([winfo width $anchor]-[winfo reqwidth $w])/2}]
 108         set y [expr {[winfo rooty $anchor] + \
 109                 ([winfo height $anchor]-[winfo reqheight $w])/2}]
 110     } else {
 111         set x [expr {([winfo screenwidth $w]-[winfo reqwidth $w])/2}]
 112         set y [expr {([winfo screenheight $w]-[winfo reqheight $w])/2}]
 113         set checkBounds 0
 114     }
 115     if {[tk windowingsystem] eq "win32"} {
 116         # Bug 533519: win32 multiple desktops may produce negative geometry.
 117         set checkBounds 0
 118     }
 119     if {$checkBounds} {
 120         if {$x < 0} {
 121             set x 0
 122         } elseif {$x > ([winfo screenwidth $w]-[winfo reqwidth $w])} {
 123             set x [expr {[winfo screenwidth $w]-[winfo reqwidth $w]}]
 124         }
 125         if {$y < 0} {
 126             set y 0
 127         } elseif {$y > ([winfo screenheight $w]-[winfo reqheight $w])} {
 128             set y [expr {[winfo screenheight $w]-[winfo reqheight $w]}]
 129         }
 130         if {[tk windowingsystem] eq "aqua"} {
 131             # Avoid the native menu bar which sits on top of everything.
 132             if {$y < 22} { set y 22 }
 133         }
 134     }
 135     wm geometry $w +$x+$y
 136     wm deiconify $w
 137 }
 138 \f
 139 # ::tk::SetFocusGrab --
 140 #   Swap out current focus and grab temporarily (for dialogs)
 141 # Arguments:
 142 #   grab        new window to grab
 143 #   focus       window to give focus to
 144 # Results:
 145 #   Returns nothing
 146 #
 147 proc ::tk::SetFocusGrab {grab {focus {}}} {
 148     set index "$grab,$focus"
 149     upvar ::tk::FocusGrab($index) data
 150
 151     lappend data [focus]
 152     set oldGrab [grab current $grab]
 153     lappend data $oldGrab
 154     if {[winfo exists $oldGrab]} {
 155         lappend data [grab status $oldGrab]
 156     }
 157     # The "grab" command will fail if another application already holds the
 158     # grab.  So catch it.
 159     catch {grab $grab}
 160     if {[winfo exists $focus]} {
 161         focus $focus
 162     }
 163 }
 164
 165 # ::tk::RestoreFocusGrab --
 166 #   Restore old focus and grab (for dialogs)
 167 # Arguments:
 168 #   grab        window that had taken grab
 169 #   focus       window that had taken focus
 170 #   destroy     destroy|withdraw - how to handle the old grabbed window
 171 # Results:
 172 #   Returns nothing
 173 #
 174 proc ::tk::RestoreFocusGrab {grab focus {destroy destroy}} {
 175     set index "$grab,$focus"
 176     if {[info exists ::tk::FocusGrab($index)]} {
 177         foreach {oldFocus oldGrab oldStatus} $::tk::FocusGrab($index) { break }
 178         unset ::tk::FocusGrab($index)
 179     } else {
 180         set oldGrab ""
 181     }
 182
 183     catch {focus $oldFocus}
 184     grab release $grab
 185     if {$destroy eq "withdraw"} {
 186         wm withdraw $grab
 187     } else {
 188         destroy $grab
 189     }
 190     if {[winfo exists $oldGrab] && [winfo ismapped $oldGrab]} {
 191         if {$oldStatus eq "global"} {
 192             grab -global $oldGrab
 193         } else {
 194             grab $oldGrab
 195         }
 196     }
 197 }
 198 \f
 199 # ::tk::GetSelection --
 200 #   This tries to obtain the default selection.  On Unix, we first try and get
 201 #   a UTF8_STRING, a type supported by modern Unix apps for passing Unicode
 202 #   data safely.  We fall back on the default STRING type otherwise.  On
 203 #   Windows, only the STRING type is necessary.
 204 # Arguments:
 205 #   w   The widget for which the selection will be retrieved.
 206 #       Important for the -displayof property.
 207 #   sel The source of the selection (PRIMARY or CLIPBOARD)
 208 # Results:
 209 #   Returns the selection, or an error if none could be found
 210 #
 211 if {$tcl_platform(platform) eq "unix"} {
 212     proc ::tk::GetSelection {w {sel PRIMARY}} {
 213         if {[catch {selection get -displayof $w -selection $sel \
 214                 -type UTF8_STRING} txt] \
 215                 && [catch {selection get -displayof $w -selection $sel} txt]} {
 216             return -code error "could not find default selection"
 217         } else {
 218             return $txt
 219         }
 220     }
 221 } else {
 222     proc ::tk::GetSelection {w {sel PRIMARY}} {
 223         if {[catch {selection get -displayof $w -selection $sel} txt]} {
 224             return -code error "could not find default selection"
 225         } else {
 226             return $txt
 227         }
 228     }
 229 }
 230 \f
 231 # ::tk::ScreenChanged --
 232 # This procedure is invoked by the binding mechanism whenever the "current"
 233 # screen is changing.  The procedure does two things.  First, it uses "upvar"
 234 # to make variable "::tk::Priv" point at an array variable that holds state
 235 # for the current display.  Second, it initializes the array if it didn't
 236 # already exist.
 237 #
 238 # Arguments:
 239 # screen -              The name of the new screen.
 240
 241 proc ::tk::ScreenChanged {screen} {
 242     set x [string last . $screen]
 243     if {$x > 0} {
 244         set disp [string range $screen 0 [expr {$x - 1}]]
 245     } else {
 246         set disp $screen
 247     }
 248
 249     # Ensure that namespace separators never occur in the display name (as
 250     # they cause problems in variable names). Double-colons exist in some VNC
 251     # display names. [Bug 2912473]
 252     set disp [string map {:: _doublecolon_} $disp]
 253
 254     uplevel #0 [list upvar #0 ::tk::Priv.$disp ::tk::Priv]
 255     variable ::tk::Priv
 256     global tcl_platform
 257
 258     if {[info exists Priv]} {
 259         set Priv(screen) $screen
 260         return
 261     }
 262     array set Priv {
 263         activeMenu      {}
 264         activeItem      {}
 265         afterId         {}
 266         buttons         0
 267         buttonWindow    {}
 268         dragging        0
 269         focus           {}
 270         grab            {}
 271         initPos         {}
 272         inMenubutton    {}
 273         listboxPrev     {}
 274         menuBar         {}
 275         mouseMoved      0
 276         oldGrab         {}
 277         popup           {}
 278         postedMb        {}
 279         pressX          0
 280         pressY          0
 281         prevPos         0
 282         selectMode      char
 283     }
 284     set Priv(screen) $screen
 285     set Priv(tearoff) [string equal [tk windowingsystem] "x11"]
 286     set Priv(window) {}
 287 }
 288
 289 # Do initial setup for Priv, so that it is always bound to something
 290 # (otherwise, if someone references it, it may get set to a non-upvar-ed
 291 # value, which will cause trouble later).
 292
 293 tk::ScreenChanged [winfo screen .]
 294 \f
 295 # ::tk::EventMotifBindings --
 296 # This procedure is invoked as a trace whenever ::tk_strictMotif is changed.
 297 # It is used to turn on or turn off the motif virtual bindings.
 298 #
 299 # Arguments:
 300 # n1 - the name of the variable being changed ("::tk_strictMotif").
 301
 302 proc ::tk::EventMotifBindings {n1 dummy dummy} {
 303     upvar $n1 name
 304
 305     if {$name} {
 306         set op delete
 307     } else {
 308         set op add
 309     }
 310
 311     event $op <<Cut>> <Control-Key-w>
 312     event $op <<Copy>> <Meta-Key-w>
 313     event $op <<Paste>> <Control-Key-y>
 314     event $op <<Undo>> <Control-underscore>
 315 }
 316 \f
 317 #----------------------------------------------------------------------
 318 # Define common dialogs on platforms where they are not implemented using
 319 # compiled code.
 320 #----------------------------------------------------------------------
 321
 322 if {![llength [info commands tk_chooseColor]]} {
 323     proc ::tk_chooseColor {args} {
 324         return [tk::dialog::color:: {*}$args]
 325     }
 326 }
 327 if {![llength [info commands tk_getOpenFile]]} {
 328     proc ::tk_getOpenFile {args} {
 329         if {$::tk_strictMotif} {
 330             return [tk::MotifFDialog open {*}$args]
 331         } else {
 332             return [::tk::dialog::file:: open {*}$args]
 333         }
 334     }
 335 }
 336 if {![llength [info commands tk_getSaveFile]]} {
 337     proc ::tk_getSaveFile {args} {
 338         if {$::tk_strictMotif} {
 339             return [tk::MotifFDialog save {*}$args]
 340         } else {
 341             return [::tk::dialog::file:: save {*}$args]
 342         }
 343     }
 344 }
 345 if {![llength [info commands tk_messageBox]]} {
 346     proc ::tk_messageBox {args} {
 347         return [tk::MessageBox {*}$args]
 348     }
 349 }
 350 if {![llength [info command tk_chooseDirectory]]} {
 351     proc ::tk_chooseDirectory {args} {
 352         return [::tk::dialog::file::chooseDir:: {*}$args]
 353     }
 354 }
 355 \f
 356 #----------------------------------------------------------------------
 357 # Define the set of common virtual events.
 358 #----------------------------------------------------------------------
 359
 360 switch -exact -- [tk windowingsystem] {
 361     "x11" {
 362         event add <<Cut>> <Control-Key-x> <Key-F20> <Control-Lock-Key-X>
 363         event add <<Copy>> <Control-Key-c> <Key-F16> <Control-Lock-Key-C>
 364         event add <<Paste>> <Control-Key-v> <Key-F18> <Control-Lock-Key-V>
 365         event add <<PasteSelection>> <ButtonRelease-2>
 366         event add <<Undo>> <Control-Key-z> <Control-Lock-Key-Z>
 367         event add <<Redo>> <Control-Key-Z> <Control-Lock-Key-z>
 368         # Some OS's define a goofy (as in, not <Shift-Tab>) keysym that is
 369         # returned when the user presses <Shift-Tab>. In order for tab
 370         # traversal to work, we have to add these keysyms to the PrevWindow
 371         # event. We use catch just in case the keysym isn't recognized. This
 372         # is needed for XFree86 systems
 373         catch { event add <<PrevWindow>> <ISO_Left_Tab> }
 374         # This seems to be correct on *some* HP systems.
 375         catch { event add <<PrevWindow>> <hpBackTab> }
 376
 377         trace add variable ::tk_strictMotif write ::tk::EventMotifBindings
 378         set ::tk_strictMotif $::tk_strictMotif
 379         # On unix, we want to always display entry/text selection, regardless
 380         # of which window has focus
 381         set ::tk::AlwaysShowSelection 1
 382     }
 383     "win32" {
 384         event add <<Cut>> <Control-Key-x> <Shift-Key-Delete> \
 385             <Control-Lock-Key-X>
 386         event add <<Copy>> <Control-Key-c> <Control-Key-Insert> \
 387             <Control-Lock-Key-C>
 388         event add <<Paste>> <Control-Key-v> <Shift-Key-Insert> \
 389             <Control-Lock-Key-V>
 390         event add <<PasteSelection>> <ButtonRelease-2>
 391         event add <<Undo>> <Control-Key-z> <Control-Lock-Key-Z>
 392         event add <<Redo>> <Control-Key-y> <Control-Lock-Key-Y>
 393     }
 394     "aqua" {
 395         event add <<Cut>> <Command-Key-x> <Key-F2> <Control-Lock-Key-X>
 396         event add <<Copy>> <Command-Key-c> <Key-F3> <Control-Lock-Key-C>
 397         event add <<Paste>> <Command-Key-v> <Key-F4> <Control-Lock-Key-V>
 398         event add <<PasteSelection>> <ButtonRelease-2>
 399         event add <<Clear>> <Clear>
 400         event add <<Undo>> <Command-Key-z> <Control-Lock-Key-Z>
 401         event add <<Redo>> <Command-Key-y> <Control-Lock-Key-Y>
 402     }
 403 }
 404
 405 # ----------------------------------------------------------------------
 406 # Read in files that define all of the class bindings.
 407 # ----------------------------------------------------------------------
 408
 409 if {$::tk_library ne ""} {
 410     proc ::tk::SourceLibFile {file} {
 411         namespace eval :: [list source [file join $::tk_library $file.tcl]]
 412     }
 413     namespace eval ::tk {
 414         SourceLibFile button
 415         SourceLibFile entry
 416         SourceLibFile listbox
 417         SourceLibFile menu
 418         SourceLibFile panedwindow
 419         SourceLibFile scale
 420         SourceLibFile scrlbar
 421         SourceLibFile spinbox
 422         SourceLibFile text
 423     }
 424 }
 425
 426 # ----------------------------------------------------------------------
 427 # Default bindings for keyboard traversal.
 428 # ----------------------------------------------------------------------
 429
 430 event add <<PrevWindow>> <Shift-Tab>
 431 bind all <Tab> {tk::TabToWindow [tk_focusNext %W]}
 432 bind all <<PrevWindow>> {tk::TabToWindow [tk_focusPrev %W]}
 433 \f
 434 # ::tk::CancelRepeat --
 435 # This procedure is invoked to cancel an auto-repeat action described by
 436 # ::tk::Priv(afterId).  It's used by several widgets to auto-scroll the widget
 437 # when the mouse is dragged out of the widget with a button pressed.
 438 #
 439 # Arguments:
 440 # None.
 441
 442 proc ::tk::CancelRepeat {} {
 443     variable ::tk::Priv
 444     after cancel $Priv(afterId)
 445     set Priv(afterId) {}
 446 }
 447 \f
 448 # ::tk::TabToWindow --
 449 # This procedure moves the focus to the given widget.
 450 # It sends a <<TraverseOut>> virtual event to the previous focus window, if
 451 # any, before changing the focus, and a <<TraverseIn>> event to the new focus
 452 # window afterwards.
 453 #
 454 # Arguments:
 455 # w - Window to which focus should be set.
 456
 457 proc ::tk::TabToWindow {w} {
 458     set focus [focus]
 459     if {$focus ne ""} {
 460         event generate $focus <<TraverseOut>>
 461     }
 462     focus $w
 463     event generate $w <<TraverseIn>>
 464 }
 465 \f
 466 # ::tk::UnderlineAmpersand --
 467 # This procedure takes some text with ampersand and returns text w/o ampersand
 468 # and position of the ampersand.  Double ampersands are converted to single
 469 # ones.  Position returned is -1 when there is no ampersand.
 470 #
 471 proc ::tk::UnderlineAmpersand {text} {
 472     set s [string map {&& & & \ufeff} $text]
 473     set idx [string first \ufeff $s]
 474     return [list [string map {\ufeff {}} $s] $idx]
 475 }
 476
 477 # ::tk::SetAmpText --
 478 # Given widget path and text with "magic ampersands", sets -text and
 479 # -underline options for the widget
 480 #
 481 proc ::tk::SetAmpText {widget text} {
 482     lassign [UnderlineAmpersand $text] newtext under
 483     $widget configure -text $newtext -underline $under
 484 }
 485
 486 # ::tk::AmpWidget --
 487 # Creates new widget, turning -text option into -text and -underline options,
 488 # returned by ::tk::UnderlineAmpersand.
 489 #
 490 proc ::tk::AmpWidget {class path args} {
 491     set options {}
 492     foreach {opt val} $args {
 493         if {$opt eq "-text"} {
 494             lassign [UnderlineAmpersand $val] newtext under
 495             lappend options -text $newtext -underline $under
 496         } else {
 497             lappend options $opt $val
 498         }
 499     }
 500     set result [$class $path {*}$options]
 501     if {[string match "*button" $class]} {
 502         bind $path <<AltUnderlined>> [list $path invoke]
 503     }
 504     return $result
 505 }
 506
 507 # ::tk::AmpMenuArgs --
 508 # Processes arguments for a menu entry, turning -label option into -label and
 509 # -underline options, returned by ::tk::UnderlineAmpersand.
 510 #
 511 proc ::tk::AmpMenuArgs {widget add type args} {
 512     set options {}
 513     foreach {opt val} $args {
 514         if {$opt eq "-label"} {
 515             lassign [UnderlineAmpersand $val] newlabel under
 516             lappend options -label $newlabel -underline $under
 517         } else {
 518             lappend options $opt $val
 519         }
 520     }
 521     $widget add $type {*}$options
 522 }
 523 \f
 524 # ::tk::FindAltKeyTarget --
 525 # Search recursively through the hierarchy of visible widgets to find button
 526 # or label which has $char as underlined character
 527 #
 528 proc ::tk::FindAltKeyTarget {path char} {
 529     switch -- [winfo class $path] {
 530         Button - Label -
 531         TButton - TLabel - TCheckbutton {
 532             if {[string equal -nocase $char \
 533                   [string index [$path cget -text] [$path cget -underline]]]} {
 534                 return $path
 535             } else {
 536                 return {}
 537             }
 538         }
 539         default {
 540             foreach child [concat [grid slaves $path] \
 541                     [pack slaves $path] [place slaves $path]] {
 542                 set target [FindAltKeyTarget $child $char]
 543                 if {$target ne ""} {
 544                     return $target
 545                 }
 546             }
 547         }
 548     }
 549     return {}
 550 }
 551
 552 # ::tk::AltKeyInDialog --
 553 # <Alt-Key> event handler for standard dialogs. Sends <<AltUnderlined>> to
 554 # button or label which has appropriate underlined character
 555 #
 556 proc ::tk::AltKeyInDialog {path key} {
 557     set target [FindAltKeyTarget $path $key]
 558     if { $target eq ""} return
 559     event generate $target <<AltUnderlined>>
 560 }
 561 \f
 562 # ::tk::mcmaxamp --
 563 # Replacement for mcmax, used for texts with "magic ampersand" in it.
 564 #
 565
 566 proc ::tk::mcmaxamp {args} {
 567     set maxlen 0
 568     foreach arg $args {
 569         # Should we run [mc] in caller's namespace?
 570         lassign [UnderlineAmpersand [mc $arg]] msg
 571         set length [string length $msg]
 572         if {$length > $maxlen} {
 573             set maxlen $length
 574         }
 575     }
 576     return $maxlen
 577 }
 578 \f
 579 # For now, turn off the custom mdef proc for the mac:
 580
 581 if {[tk windowingsystem] eq "aqua"} {
 582     namespace eval ::tk::mac {
 583         variable useCustomMDEF 0
 584     }
 585 }
 586
 587 # Run the Ttk themed widget set initialization
 588 if {$::ttk::library ne ""} {
 589     uplevel \#0 [list source [file join $::ttk::library ttk.tcl]]
 590 }
 591 \f
 592 # Local Variables:
 593 # mode: tcl
 594 # fill-column: 78
 595 # End: