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.13
  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 {$checkBounds} {
 116         if {$x < [winfo vrootx $w]} {
 117             set x [winfo vrootx $w]
 118         } elseif {$x > ([winfo vrootx $w]+[winfo vrootwidth $w]-[winfo reqwidth $w])} {
 119             set x [expr {[winfo vrootx $w]+[winfo vrootwidth $w]-[winfo reqwidth $w]}]
 120         }
 121         if {$y < [winfo vrooty $w]} {
 122             set y [winfo vrooty $w]
 123         } elseif {$y > ([winfo vrooty $w]+[winfo vrootheight $w]-[winfo reqheight $w])} {
 124             set y [expr {[winfo vrooty $w]+[winfo vrootheight $w]-[winfo reqheight $w]}]
 125         }
 126         if {[tk windowingsystem] eq "aqua"} {
 127             # Avoid the native menu bar which sits on top of everything.
 128             if {$y < 22} { set y 22 }
 129         }
 130     }
 131     wm maxsize $w [winfo vrootwidth $w] [winfo vrootheight $w]
 132     wm geometry $w +$x+$y
 133     wm deiconify $w
 134 }
 135 \f
 136 # ::tk::SetFocusGrab --
 137 #   Swap out current focus and grab temporarily (for dialogs)
 138 # Arguments:
 139 #   grab        new window to grab
 140 #   focus       window to give focus to
 141 # Results:
 142 #   Returns nothing
 143 #
 144 proc ::tk::SetFocusGrab {grab {focus {}}} {
 145     set index "$grab,$focus"
 146     upvar ::tk::FocusGrab($index) data
 147
 148     lappend data [focus]
 149     set oldGrab [grab current $grab]
 150     lappend data $oldGrab
 151     if {[winfo exists $oldGrab]} {
 152         lappend data [grab status $oldGrab]
 153     }
 154     # The "grab" command will fail if another application already holds the
 155     # grab.  So catch it.
 156     catch {grab $grab}
 157     if {[winfo exists $focus]} {
 158         focus $focus
 159     }
 160 }
 161
 162 # ::tk::RestoreFocusGrab --
 163 #   Restore old focus and grab (for dialogs)
 164 # Arguments:
 165 #   grab        window that had taken grab
 166 #   focus       window that had taken focus
 167 #   destroy     destroy|withdraw - how to handle the old grabbed window
 168 # Results:
 169 #   Returns nothing
 170 #
 171 proc ::tk::RestoreFocusGrab {grab focus {destroy destroy}} {
 172     set index "$grab,$focus"
 173     if {[info exists ::tk::FocusGrab($index)]} {
 174         foreach {oldFocus oldGrab oldStatus} $::tk::FocusGrab($index) { break }
 175         unset ::tk::FocusGrab($index)
 176     } else {
 177         set oldGrab ""
 178     }
 179
 180     catch {focus $oldFocus}
 181     grab release $grab
 182     if {$destroy eq "withdraw"} {
 183         wm withdraw $grab
 184     } else {
 185         destroy $grab
 186     }
 187     if {[winfo exists $oldGrab] && [winfo ismapped $oldGrab]} {
 188         if {$oldStatus eq "global"} {
 189             grab -global $oldGrab
 190         } else {
 191             grab $oldGrab
 192         }
 193     }
 194 }
 195 \f
 196 # ::tk::GetSelection --
 197 #   This tries to obtain the default selection.  On Unix, we first try and get
 198 #   a UTF8_STRING, a type supported by modern Unix apps for passing Unicode
 199 #   data safely.  We fall back on the default STRING type otherwise.  On
 200 #   Windows, only the STRING type is necessary.
 201 # Arguments:
 202 #   w   The widget for which the selection will be retrieved.
 203 #       Important for the -displayof property.
 204 #   sel The source of the selection (PRIMARY or CLIPBOARD)
 205 # Results:
 206 #   Returns the selection, or an error if none could be found
 207 #
 208 if {[tk windowingsystem] ne "win32"} {
 209     proc ::tk::GetSelection {w {sel PRIMARY}} {
 210         if {[catch {selection get -displayof $w -selection $sel \
 211                 -type UTF8_STRING} txt] \
 212                 && [catch {selection get -displayof $w -selection $sel} txt]} {
 213             return -code error "could not find default selection"
 214         } else {
 215             return $txt
 216         }
 217     }
 218 } else {
 219     proc ::tk::GetSelection {w {sel PRIMARY}} {
 220         if {[catch {selection get -displayof $w -selection $sel} txt]} {
 221             return -code error "could not find default selection"
 222         } else {
 223             return $txt
 224         }
 225     }
 226 }
 227 \f
 228 # ::tk::ScreenChanged --
 229 # This procedure is invoked by the binding mechanism whenever the "current"
 230 # screen is changing.  The procedure does two things.  First, it uses "upvar"
 231 # to make variable "::tk::Priv" point at an array variable that holds state
 232 # for the current display.  Second, it initializes the array if it didn't
 233 # already exist.
 234 #
 235 # Arguments:
 236 # screen -              The name of the new screen.
 237
 238 proc ::tk::ScreenChanged {screen} {
 239     set x [string last . $screen]
 240     if {$x > 0} {
 241         set disp [string range $screen 0 [expr {$x - 1}]]
 242     } else {
 243         set disp $screen
 244     }
 245
 246     # Ensure that namespace separators never occur in the display name (as
 247     # they cause problems in variable names). Double-colons exist in some VNC
 248     # display names. [Bug 2912473]
 249     set disp [string map {:: _doublecolon_} $disp]
 250
 251     uplevel #0 [list upvar #0 ::tk::Priv.$disp ::tk::Priv]
 252     variable ::tk::Priv
 253     global tcl_platform
 254
 255     if {[info exists Priv]} {
 256         set Priv(screen) $screen
 257         return
 258     }
 259     array set Priv {
 260         activeMenu      {}
 261         activeItem      {}
 262         afterId         {}
 263         buttons         0
 264         buttonWindow    {}
 265         dragging        0
 266         focus           {}
 267         grab            {}
 268         initPos         {}
 269         inMenubutton    {}
 270         listboxPrev     {}
 271         menuBar         {}
 272         mouseMoved      0
 273         oldGrab         {}
 274         popup           {}
 275         postedMb        {}
 276         pressX          0
 277         pressY          0
 278         prevPos         0
 279         selectMode      char
 280     }
 281     set Priv(screen) $screen
 282     set Priv(tearoff) [string equal [tk windowingsystem] "x11"]
 283     set Priv(window) {}
 284 }
 285
 286 # Do initial setup for Priv, so that it is always bound to something
 287 # (otherwise, if someone references it, it may get set to a non-upvar-ed
 288 # value, which will cause trouble later).
 289
 290 tk::ScreenChanged [winfo screen .]
 291 \f
 292 # ::tk::EventMotifBindings --
 293 # This procedure is invoked as a trace whenever ::tk_strictMotif is changed.
 294 # It is used to turn on or turn off the motif virtual bindings.
 295 #
 296 # Arguments:
 297 # n1 - the name of the variable being changed ("::tk_strictMotif").
 298
 299 proc ::tk::EventMotifBindings {n1 dummy dummy} {
 300     upvar $n1 name
 301
 302     if {$name} {
 303         set op delete
 304     } else {
 305         set op add
 306     }
 307
 308     event $op <<Cut>> <Control-Key-w>
 309     event $op <<Copy>> <Meta-Key-w>
 310     event $op <<Paste>> <Control-Key-y>
 311     event $op <<Undo>> <Control-underscore>
 312 }
 313 \f
 314 #----------------------------------------------------------------------
 315 # Define common dialogs on platforms where they are not implemented using
 316 # compiled code.
 317 #----------------------------------------------------------------------
 318
 319 if {![llength [info commands tk_chooseColor]]} {
 320     proc ::tk_chooseColor {args} {
 321         return [tk::dialog::color:: {*}$args]
 322     }
 323 }
 324 if {![llength [info commands tk_getOpenFile]]} {
 325     proc ::tk_getOpenFile {args} {
 326         if {$::tk_strictMotif} {
 327             return [tk::MotifFDialog open {*}$args]
 328         } else {
 329             return [::tk::dialog::file:: open {*}$args]
 330         }
 331     }
 332 }
 333 if {![llength [info commands tk_getSaveFile]]} {
 334     proc ::tk_getSaveFile {args} {
 335         if {$::tk_strictMotif} {
 336             return [tk::MotifFDialog save {*}$args]
 337         } else {
 338             return [::tk::dialog::file:: save {*}$args]
 339         }
 340     }
 341 }
 342 if {![llength [info commands tk_messageBox]]} {
 343     proc ::tk_messageBox {args} {
 344         return [tk::MessageBox {*}$args]
 345     }
 346 }
 347 if {![llength [info command tk_chooseDirectory]]} {
 348     proc ::tk_chooseDirectory {args} {
 349         return [::tk::dialog::file::chooseDir:: {*}$args]
 350     }
 351 }
 352 \f
 353 #----------------------------------------------------------------------
 354 # Define the set of common virtual events.
 355 #----------------------------------------------------------------------
 356
 357 switch -exact -- [tk windowingsystem] {
 358     "x11" {
 359         event add <<Cut>> <Control-Key-x> <Key-F20> <Control-Lock-Key-X>
 360         event add <<Copy>> <Control-Key-c> <Key-F16> <Control-Lock-Key-C>
 361         event add <<Paste>> <Control-Key-v> <Key-F18> <Control-Lock-Key-V>
 362         event add <<PasteSelection>> <ButtonRelease-2>
 363         event add <<Undo>> <Control-Key-z> <Control-Lock-Key-Z>
 364         event add <<Redo>> <Control-Key-Z> <Control-Lock-Key-z>
 365         # Some OS's define a goofy (as in, not <Shift-Tab>) keysym that is
 366         # returned when the user presses <Shift-Tab>. In order for tab
 367         # traversal to work, we have to add these keysyms to the PrevWindow
 368         # event. We use catch just in case the keysym isn't recognized. This
 369         # is needed for XFree86 systems
 370         catch { event add <<PrevWindow>> <ISO_Left_Tab> }
 371         # This seems to be correct on *some* HP systems.
 372         catch { event add <<PrevWindow>> <hpBackTab> }
 373
 374         trace add variable ::tk_strictMotif write ::tk::EventMotifBindings
 375         set ::tk_strictMotif $::tk_strictMotif
 376         # On unix, we want to always display entry/text selection, regardless
 377         # of which window has focus
 378         set ::tk::AlwaysShowSelection 1
 379     }
 380     "win32" {
 381         event add <<Cut>> <Control-Key-x> <Shift-Key-Delete> \
 382             <Control-Lock-Key-X>
 383         event add <<Copy>> <Control-Key-c> <Control-Key-Insert> \
 384             <Control-Lock-Key-C>
 385         event add <<Paste>> <Control-Key-v> <Shift-Key-Insert> \
 386             <Control-Lock-Key-V>
 387         event add <<PasteSelection>> <ButtonRelease-2>
 388         event add <<Undo>> <Control-Key-z> <Control-Lock-Key-Z>
 389         event add <<Redo>> <Control-Key-y> <Control-Lock-Key-Y>
 390     }
 391     "aqua" {
 392         event add <<Cut>> <Command-Key-x> <Key-F2> <Control-Lock-Key-X>
 393         event add <<Copy>> <Command-Key-c> <Key-F3> <Control-Lock-Key-C>
 394         event add <<Paste>> <Command-Key-v> <Key-F4> <Control-Lock-Key-V>
 395         event add <<PasteSelection>> <ButtonRelease-2>
 396         event add <<Clear>> <Clear>
 397         event add <<Undo>> <Command-Key-z> <Control-Lock-Key-Z>
 398         event add <<Redo>> <Command-Key-y> <Control-Lock-Key-Y>
 399     }
 400 }
 401
 402 # ----------------------------------------------------------------------
 403 # Read in files that define all of the class bindings.
 404 # ----------------------------------------------------------------------
 405
 406 if {$::tk_library ne ""} {
 407     proc ::tk::SourceLibFile {file} {
 408         namespace eval :: [list source [file join $::tk_library $file.tcl]]
 409     }
 410     namespace eval ::tk {
 411         SourceLibFile button
 412         SourceLibFile entry
 413         SourceLibFile listbox
 414         SourceLibFile menu
 415         SourceLibFile panedwindow
 416         SourceLibFile scale
 417         SourceLibFile scrlbar
 418         SourceLibFile spinbox
 419         SourceLibFile text
 420     }
 421 }
 422
 423 # ----------------------------------------------------------------------
 424 # Default bindings for keyboard traversal.
 425 # ----------------------------------------------------------------------
 426
 427 event add <<PrevWindow>> <Shift-Tab>
 428 bind all <Tab> {tk::TabToWindow [tk_focusNext %W]}
 429 bind all <<PrevWindow>> {tk::TabToWindow [tk_focusPrev %W]}
 430 \f
 431 # ::tk::CancelRepeat --
 432 # This procedure is invoked to cancel an auto-repeat action described by
 433 # ::tk::Priv(afterId).  It's used by several widgets to auto-scroll the widget
 434 # when the mouse is dragged out of the widget with a button pressed.
 435 #
 436 # Arguments:
 437 # None.
 438
 439 proc ::tk::CancelRepeat {} {
 440     variable ::tk::Priv
 441     after cancel $Priv(afterId)
 442     set Priv(afterId) {}
 443 }
 444 \f
 445 # ::tk::TabToWindow --
 446 # This procedure moves the focus to the given widget.
 447 # It sends a <<TraverseOut>> virtual event to the previous focus window, if
 448 # any, before changing the focus, and a <<TraverseIn>> event to the new focus
 449 # window afterwards.
 450 #
 451 # Arguments:
 452 # w - Window to which focus should be set.
 453
 454 proc ::tk::TabToWindow {w} {
 455     set focus [focus]
 456     if {$focus ne ""} {
 457         event generate $focus <<TraverseOut>>
 458     }
 459     focus $w
 460     event generate $w <<TraverseIn>>
 461 }
 462 \f
 463 # ::tk::UnderlineAmpersand --
 464 # This procedure takes some text with ampersand and returns text w/o ampersand
 465 # and position of the ampersand.  Double ampersands are converted to single
 466 # ones.  Position returned is -1 when there is no ampersand.
 467 #
 468 proc ::tk::UnderlineAmpersand {text} {
 469     set s [string map {&& & & \ufeff} $text]
 470     set idx [string first \ufeff $s]
 471     return [list [string map {\ufeff {}} $s] $idx]
 472 }
 473
 474 # ::tk::SetAmpText --
 475 # Given widget path and text with "magic ampersands", sets -text and
 476 # -underline options for the widget
 477 #
 478 proc ::tk::SetAmpText {widget text} {
 479     lassign [UnderlineAmpersand $text] newtext under
 480     $widget configure -text $newtext -underline $under
 481 }
 482
 483 # ::tk::AmpWidget --
 484 # Creates new widget, turning -text option into -text and -underline options,
 485 # returned by ::tk::UnderlineAmpersand.
 486 #
 487 proc ::tk::AmpWidget {class path args} {
 488     set options {}
 489     foreach {opt val} $args {
 490         if {$opt eq "-text"} {
 491             lassign [UnderlineAmpersand $val] newtext under
 492             lappend options -text $newtext -underline $under
 493         } else {
 494             lappend options $opt $val
 495         }
 496     }
 497     set result [$class $path {*}$options]
 498     if {[string match "*button" $class]} {
 499         bind $path <<AltUnderlined>> [list $path invoke]
 500     }
 501     return $result
 502 }
 503
 504 # ::tk::AmpMenuArgs --
 505 # Processes arguments for a menu entry, turning -label option into -label and
 506 # -underline options, returned by ::tk::UnderlineAmpersand.
 507 #
 508 proc ::tk::AmpMenuArgs {widget add type args} {
 509     set options {}
 510     foreach {opt val} $args {
 511         if {$opt eq "-label"} {
 512             lassign [UnderlineAmpersand $val] newlabel under
 513             lappend options -label $newlabel -underline $under
 514         } else {
 515             lappend options $opt $val
 516         }
 517     }
 518     $widget add $type {*}$options
 519 }
 520 \f
 521 # ::tk::FindAltKeyTarget --
 522 # Search recursively through the hierarchy of visible widgets to find button
 523 # or label which has $char as underlined character
 524 #
 525 proc ::tk::FindAltKeyTarget {path char} {
 526     switch -- [winfo class $path] {
 527         Button - Label -
 528         TButton - TLabel - TCheckbutton {
 529             if {[string equal -nocase $char \
 530                   [string index [$path cget -text] [$path cget -underline]]]} {
 531                 return $path
 532             } else {
 533                 return {}
 534             }
 535         }
 536         default {
 537             foreach child [concat [grid slaves $path] \
 538                     [pack slaves $path] [place slaves $path]] {
 539                 set target [FindAltKeyTarget $child $char]
 540                 if {$target ne ""} {
 541                     return $target
 542                 }
 543             }
 544         }
 545     }
 546     return {}
 547 }
 548
 549 # ::tk::AltKeyInDialog --
 550 # <Alt-Key> event handler for standard dialogs. Sends <<AltUnderlined>> to
 551 # button or label which has appropriate underlined character
 552 #
 553 proc ::tk::AltKeyInDialog {path key} {
 554     set target [FindAltKeyTarget $path $key]
 555     if { $target eq ""} return
 556     event generate $target <<AltUnderlined>>
 557 }
 558 \f
 559 # ::tk::mcmaxamp --
 560 # Replacement for mcmax, used for texts with "magic ampersand" in it.
 561 #
 562
 563 proc ::tk::mcmaxamp {args} {
 564     set maxlen 0
 565     foreach arg $args {
 566         # Should we run [mc] in caller's namespace?
 567         lassign [UnderlineAmpersand [mc $arg]] msg
 568         set length [string length $msg]
 569         if {$length > $maxlen} {
 570             set maxlen $length
 571         }
 572     }
 573     return $maxlen
 574 }
 575 \f
 576 # For now, turn off the custom mdef proc for the mac:
 577
 578 if {[tk windowingsystem] eq "aqua"} {
 579     namespace eval ::tk::mac {
 580         variable useCustomMDEF 0
 581     }
 582 }
 583
 584 # Run the Ttk themed widget set initialization
 585 if {$::ttk::library ne ""} {
 586     uplevel \#0 [list source [file join $::ttk::library ttk.tcl]]
 587 }
 588 \f
 589 # Local Variables:
 590 # mode: tcl
 591 # fill-column: 78
 592 # End: