diff options
Diffstat (limited to 'library/tk.tcl')
| -rw-r--r-- | library/tk.tcl | 257 |
1 files changed, 160 insertions, 97 deletions
diff --git a/library/tk.tcl b/library/tk.tcl index 8e967cb..5e6f4a6 100644 --- a/library/tk.tcl +++ b/library/tk.tcl @@ -10,23 +10,21 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require Tcl 8.5 ;# Guard against [source] in an 8.4- interp before - ;# using 8.5 [package] features. # Insist on running with compatible version of Tcl -package require Tcl 8.5.0 +package require Tcl 8.6 # Verify that we have Tk binary and script components from the same release -package require -exact Tk 8.5.11 - +package require -exact Tk 8.6b2 + # Create a ::tk namespace namespace eval ::tk { # Set up the msgcat commands namespace eval msgcat { namespace export mc mcmax if {[interp issafe] || [catch {package require msgcat}]} { - # The msgcat package is not available. Supply our own minimal - # replacement. + # The msgcat package is not available. Supply our own + # minimal replacement. proc mc {src args} { - return [format $src {*}$args] + tailcall format $src {*}$args } proc mcmax {args} { set max 0 @@ -59,7 +57,8 @@ namespace eval ::ttk { # isn't already on the path: if {[info exists ::auto_path] && ($::tk_library ne "") - && ($::tk_library ni $::auto_path)} { + && ($::tk_library ni $::auto_path) +} then { lappend ::auto_path $::tk_library $::ttk::library } @@ -67,13 +66,13 @@ if {[info exists ::auto_path] && ($::tk_library ne "") set ::tk_strictMotif 0 -# Turn on useinputmethods (X Input Methods) by default. We catch this because -# safe interpreters may not allow the call. +# Turn on useinputmethods (X Input Methods) by default. +# We catch this because safe interpreters may not allow the call. catch {tk useinputmethods 1} # ::tk::PlaceWindow -- -# Place a toplevel at a particular position +# place a toplevel at a particular position # Arguments: # toplevel name of toplevel window # ?placement? pointer ?center? ; places $w centered on the pointer @@ -129,7 +128,9 @@ proc ::tk::PlaceWindow {w {place ""} {anchor ""}} { } if {[tk windowingsystem] eq "aqua"} { # Avoid the native menu bar which sits on top of everything. - if {$y < 22} { set y 22 } + if {$y < 22} { + set y 22 + } } } wm geometry $w +$x+$y @@ -137,7 +138,7 @@ proc ::tk::PlaceWindow {w {place ""} {anchor ""}} { } # ::tk::SetFocusGrab -- -# Swap out current focus and grab temporarily (for dialogs) +# swap out current focus and grab temporarily (for dialogs) # Arguments: # grab new window to grab # focus window to give focus to @@ -154,8 +155,8 @@ proc ::tk::SetFocusGrab {grab {focus {}}} { if {[winfo exists $oldGrab]} { lappend data [grab status $oldGrab] } - # The "grab" command will fail if another application already holds the - # grab. So catch it. + # The "grab" command will fail if another application + # already holds the grab. So catch it. catch {grab $grab} if {[winfo exists $focus]} { focus $focus @@ -163,7 +164,7 @@ proc ::tk::SetFocusGrab {grab {focus {}}} { } # ::tk::RestoreFocusGrab -- -# Restore old focus and grab (for dialogs) +# restore old focus and grab (for dialogs) # Arguments: # grab window that had taken grab # focus window that had taken focus @@ -197,10 +198,10 @@ proc ::tk::RestoreFocusGrab {grab focus {destroy destroy}} { } # ::tk::GetSelection -- -# This tries to obtain the default selection. On Unix, we first try and get -# a UTF8_STRING, a type supported by modern Unix apps for passing Unicode -# data safely. We fall back on the default STRING type otherwise. On -# Windows, only the STRING type is necessary. +# This tries to obtain the default selection. On Unix, we first try +# and get a UTF8_STRING, a type supported by modern Unix apps for +# passing Unicode data safely. We fall back on the default STRING +# type otherwise. On Windows, only the STRING type is necessary. # Arguments: # w The widget for which the selection will be retrieved. # Important for the -displayof property. @@ -210,9 +211,11 @@ proc ::tk::RestoreFocusGrab {grab focus {destroy destroy}} { # if {$tcl_platform(platform) eq "unix"} { proc ::tk::GetSelection {w {sel PRIMARY}} { - if {[catch {selection get -displayof $w -selection $sel \ - -type UTF8_STRING} txt] \ - && [catch {selection get -displayof $w -selection $sel} txt]} { + if {[catch { + selection get -displayof $w -selection $sel -type UTF8_STRING + } txt] && [catch { + selection get -displayof $w -selection $sel + } txt]} then { return -code error "could not find default selection" } else { return $txt @@ -220,7 +223,9 @@ if {$tcl_platform(platform) eq "unix"} { } } else { proc ::tk::GetSelection {w {sel PRIMARY}} { - if {[catch {selection get -displayof $w -selection $sel} txt]} { + if {[catch { + selection get -displayof $w -selection $sel + } txt]} then { return -code error "could not find default selection" } else { return $txt @@ -229,22 +234,18 @@ if {$tcl_platform(platform) eq "unix"} { } # ::tk::ScreenChanged -- -# This procedure is invoked by the binding mechanism whenever the "current" -# screen is changing. The procedure does two things. First, it uses "upvar" -# to make variable "::tk::Priv" point at an array variable that holds state -# for the current display. Second, it initializes the array if it didn't -# already exist. +# This procedure is invoked by the binding mechanism whenever the +# "current" screen is changing. The procedure does two things. +# First, it uses "upvar" to make variable "::tk::Priv" point at an +# array variable that holds state for the current display. Second, +# it initializes the array if it didn't already exist. # # Arguments: # screen - The name of the new screen. -proc ::tk::ScreenChanged {screen} { - set x [string last . $screen] - if {$x > 0} { - set disp [string range $screen 0 [expr {$x - 1}]] - } else { - set disp $screen - } +proc ::tk::ScreenChanged screen { + # Extract the display name. + set disp [string range $screen 0 [string last . $screen]-1] # Ensure that namespace separators never occur in the display name (as # they cause problems in variable names). Double-colons exist in some VNC @@ -293,8 +294,9 @@ proc ::tk::ScreenChanged {screen} { tk::ScreenChanged [winfo screen .] # ::tk::EventMotifBindings -- -# This procedure is invoked as a trace whenever ::tk_strictMotif is changed. -# It is used to turn on or turn off the motif virtual bindings. +# This procedure is invoked as a trace whenever ::tk_strictMotif is +# changed. It is used to turn on or turn off the motif virtual +# bindings. # # Arguments: # n1 - the name of the variable being changed ("::tk_strictMotif"). @@ -315,41 +317,41 @@ proc ::tk::EventMotifBindings {n1 dummy dummy} { } #---------------------------------------------------------------------- -# Define common dialogs on platforms where they are not implemented using -# compiled code. +# Define common dialogs on platforms where they are not implemented +# using compiled code. #---------------------------------------------------------------------- if {![llength [info commands tk_chooseColor]]} { proc ::tk_chooseColor {args} { - return [tk::dialog::color:: {*}$args] + tailcall ::tk::dialog::color:: {*}$args } } if {![llength [info commands tk_getOpenFile]]} { proc ::tk_getOpenFile {args} { if {$::tk_strictMotif} { - return [tk::MotifFDialog open {*}$args] + tailcall ::tk::MotifFDialog open {*}$args } else { - return [::tk::dialog::file:: open {*}$args] + tailcall ::tk::dialog::file:: open {*}$args } } } if {![llength [info commands tk_getSaveFile]]} { proc ::tk_getSaveFile {args} { if {$::tk_strictMotif} { - return [tk::MotifFDialog save {*}$args] + tailcall ::tk::MotifFDialog save {*}$args } else { - return [::tk::dialog::file:: save {*}$args] + tailcall ::tk::dialog::file:: save {*}$args } } } if {![llength [info commands tk_messageBox]]} { proc ::tk_messageBox {args} { - return [tk::MessageBox {*}$args] + tailcall ::tk::MessageBox {*}$args } } if {![llength [info command tk_chooseDirectory]]} { proc ::tk_chooseDirectory {args} { - return [::tk::dialog::file::chooseDir:: {*}$args] + tailcall ::tk::dialog::file::chooseDir:: {*}$args } } @@ -365,19 +367,38 @@ switch -exact -- [tk windowingsystem] { event add <<PasteSelection>> <ButtonRelease-2> event add <<Undo>> <Control-Key-z> <Control-Lock-Key-Z> event add <<Redo>> <Control-Key-Z> <Control-Lock-Key-z> + event add <<ContextMenu>> <Button-3> + if {[info exists tcl_platform(os)] && $tcl_platform(os) eq "Darwin"} { + event add <<ContextMenu>> <Button-2> + } + + event add <<NextChar>> <Right> + event add <<SelectNextChar>> <Shift-Right> + event add <<PrevChar>> <Left> + event add <<SelectPrevChar>> <Shift-Left> + event add <<NextWord>> <Control-Right> + event add <<SelectNextWord>> <Shift-Control-Right> + event add <<PrevWord>> <Control-Left> + event add <<SelectPrevWord>> <Shift-Control-Left> + event add <<LineStart>> <Home> + event add <<SelectLineStart>> <Shift-Home> + event add <<LineEnd>> <End> + event add <<SelectLineEnd>> <Shift-End> + # Some OS's define a goofy (as in, not <Shift-Tab>) keysym that is # returned when the user presses <Shift-Tab>. In order for tab # traversal to work, we have to add these keysyms to the PrevWindow - # event. We use catch just in case the keysym isn't recognized. This - # is needed for XFree86 systems + # event. We use catch just in case the keysym isn't recognized. + + # This is needed for XFree86 systems catch { event add <<PrevWindow>> <ISO_Left_Tab> } # This seems to be correct on *some* HP systems. catch { event add <<PrevWindow>> <hpBackTab> } trace add variable ::tk_strictMotif write ::tk::EventMotifBindings set ::tk_strictMotif $::tk_strictMotif - # On unix, we want to always display entry/text selection, regardless - # of which window has focus + # On unix, we want to always display entry/text selection, + # regardless of which window has focus set ::tk::AlwaysShowSelection 1 } "win32" { @@ -390,6 +411,20 @@ switch -exact -- [tk windowingsystem] { event add <<PasteSelection>> <ButtonRelease-2> event add <<Undo>> <Control-Key-z> <Control-Lock-Key-Z> event add <<Redo>> <Control-Key-y> <Control-Lock-Key-Y> + event add <<ContextMenu>> <Button-3> + + event add <<NextChar>> <Right> + event add <<SelectNextChar>> <Shift-Right> + event add <<PrevChar>> <Left> + event add <<SelectPrevChar>> <Shift-Left> + event add <<NextWord>> <Control-Right> + event add <<SelectNextWord>> <Shift-Control-Right> + event add <<PrevWord>> <Control-Left> + event add <<SelectPrevWord>> <Shift-Control-Left> + event add <<LineStart>> <Home> + event add <<SelectLineStart>> <Shift-Home> + event add <<LineEnd>> <End> + event add <<SelectLineEnd>> <Shift-End> } "aqua" { event add <<Cut>> <Command-Key-x> <Key-F2> <Control-Lock-Key-X> @@ -399,9 +434,27 @@ switch -exact -- [tk windowingsystem] { event add <<Clear>> <Clear> event add <<Undo>> <Command-Key-z> <Control-Lock-Key-Z> event add <<Redo>> <Command-Key-y> <Control-Lock-Key-Y> + event add <<ContextMenu>> <Button-2> + + # Official bindings + # See http://support.apple.com/kb/HT1343 + event add <<NextChar>> <Right> + event add <<SelectNextChar>> <Shift-Right> + event add <<PrevChar>> <Left> + event add <<SelectPrevChar>> <Shift-Left> + event add <<NextWord>> <Option-Right> + event add <<SelectNextWord>> <Shift-Option-Right> + event add <<PrevWord>> <Option-Left> + event add <<SelectPrevWord>> <Shift-Option-Left> + event add <<SelectLineStart>> <Shift-Home> <Shift-Command-Left> + event add <<SelectLineEnd>> <Shift-End> <Shift-Command-Right> + # Not official, but logical extensions of above. Also derived from + # bindings present in MS Word on OSX. + event add <<LineStart>> <Home> <Command-Left> + event add <<LineEnd>> <End> <Command-Right> } } - + # ---------------------------------------------------------------------- # Read in files that define all of the class bindings. # ---------------------------------------------------------------------- @@ -411,6 +464,7 @@ if {$::tk_library ne ""} { namespace eval :: [list source [file join $::tk_library $file.tcl]] } namespace eval ::tk { + SourceLibFile icons SourceLibFile button SourceLibFile entry SourceLibFile listbox @@ -428,13 +482,15 @@ if {$::tk_library ne ""} { # ---------------------------------------------------------------------- event add <<PrevWindow>> <Shift-Tab> -bind all <Tab> {tk::TabToWindow [tk_focusNext %W]} +event add <<NextWindow>> <Tab> +bind all <<NextWindow>> {tk::TabToWindow [tk_focusNext %W]} bind all <<PrevWindow>> {tk::TabToWindow [tk_focusPrev %W]} # ::tk::CancelRepeat -- -# This procedure is invoked to cancel an auto-repeat action described by -# ::tk::Priv(afterId). It's used by several widgets to auto-scroll the widget -# when the mouse is dragged out of the widget with a button pressed. +# This procedure is invoked to cancel an auto-repeat action described +# by ::tk::Priv(afterId). It's used by several widgets to auto-scroll +# the widget when the mouse is dragged out of the widget with a +# button pressed. # # Arguments: # None. @@ -447,9 +503,9 @@ proc ::tk::CancelRepeat {} { # ::tk::TabToWindow -- # This procedure moves the focus to the given widget. -# It sends a <<TraverseOut>> virtual event to the previous focus window, if -# any, before changing the focus, and a <<TraverseIn>> event to the new focus -# window afterwards. +# It sends a <<TraverseOut>> virtual event to the previous focus window, +# if any, before changing the focus, and a <<TraverseIn>> event +# to the new focus window afterwards. # # Arguments: # w - Window to which focus should be set. @@ -464,9 +520,10 @@ proc ::tk::TabToWindow {w} { } # ::tk::UnderlineAmpersand -- -# This procedure takes some text with ampersand and returns text w/o ampersand -# and position of the ampersand. Double ampersands are converted to single -# ones. Position returned is -1 when there is no ampersand. +# This procedure takes some text with ampersand and returns text w/o +# ampersand and position of the ampersand. Double ampersands are +# converted to single ones. Position returned is -1 when there is no +# ampersand. # proc ::tk::UnderlineAmpersand {text} { set s [string map {&& & & \ufeff} $text] @@ -475,8 +532,8 @@ proc ::tk::UnderlineAmpersand {text} { } # ::tk::SetAmpText -- -# Given widget path and text with "magic ampersands", sets -text and -# -underline options for the widget +# Given widget path and text with "magic ampersands", sets -text and +# -underline options for the widget # proc ::tk::SetAmpText {widget text} { lassign [UnderlineAmpersand $text] newtext under @@ -484,8 +541,8 @@ proc ::tk::SetAmpText {widget text} { } # ::tk::AmpWidget -- -# Creates new widget, turning -text option into -text and -underline options, -# returned by ::tk::UnderlineAmpersand. +# Creates new widget, turning -text option into -text and -underline +# options, returned by ::tk::UnderlineAmpersand. # proc ::tk::AmpWidget {class path args} { set options {} @@ -505,8 +562,8 @@ proc ::tk::AmpWidget {class path args} { } # ::tk::AmpMenuArgs -- -# Processes arguments for a menu entry, turning -label option into -label and -# -underline options, returned by ::tk::UnderlineAmpersand. +# Processes arguments for a menu entry, turning -label option into +# -label and -underline options, returned by ::tk::UnderlineAmpersand. # proc ::tk::AmpMenuArgs {widget add type args} { set options {} @@ -520,47 +577,53 @@ proc ::tk::AmpMenuArgs {widget add type args} { } $widget add $type {*}$options } - + # ::tk::FindAltKeyTarget -- -# Search recursively through the hierarchy of visible widgets to find button -# or label which has $char as underlined character +# Search recursively through the hierarchy of visible widgets to find +# button or label which has $char as underlined character. # proc ::tk::FindAltKeyTarget {path char} { - switch -- [winfo class $path] { - Button - Label - - TButton - TLabel - TCheckbutton { - if {[string equal -nocase $char \ - [string index [$path cget -text] [$path cget -underline]]]} { - return $path - } else { - return {} + set class [winfo class $path] + if {$class in { + Button Checkbutton Label Radiobutton + TButton TCheckbutton TLabel TRadiobutton + } && [string equal -nocase $char \ + [string index [$path cget -text] [$path cget -underline]]]} { + return $path + } + set subwins [concat [grid slaves $path] [pack slaves $path] \ + [place slaves $path]] + if {$class eq "Canvas"} { + foreach item [$path find all] { + if {[$path type $item] eq "window"} { + set w [$path itemcget $item -window] + if {$w ne ""} {lappend subwins $w} } } - default { - foreach child [concat [grid slaves $path] \ - [pack slaves $path] [place slaves $path]] { - set target [FindAltKeyTarget $child $char] - if {$target ne ""} { - return $target - } - } + } elseif {$class eq "Text"} { + lappend subwins {*}[$path window names] + } + foreach child $subwins { + set target [FindAltKeyTarget $child $char] + if {$target ne ""} { + return $target } } - return {} } # ::tk::AltKeyInDialog -- -# <Alt-Key> event handler for standard dialogs. Sends <<AltUnderlined>> to -# button or label which has appropriate underlined character +# <Alt-Key> event handler for standard dialogs. Sends <<AltUnderlined>> +# to button or label which has appropriate underlined character. # proc ::tk::AltKeyInDialog {path key} { set target [FindAltKeyTarget $path $key] - if { $target eq ""} return - event generate $target <<AltUnderlined>> + if {$target ne ""} { + event generate $target <<AltUnderlined>> + } } - + # ::tk::mcmaxamp -- -# Replacement for mcmax, used for texts with "magic ampersand" in it. +# Replacement for mcmax, used for texts with "magic ampersand" in it. # proc ::tk::mcmaxamp {args} { @@ -580,13 +643,13 @@ proc ::tk::mcmaxamp {args} { if {[tk windowingsystem] eq "aqua"} { namespace eval ::tk::mac { - variable useCustomMDEF 0 + set useCustomMDEF 0 } } # Run the Ttk themed widget set initialization if {$::ttk::library ne ""} { - uplevel \#0 [list source [file join $::ttk::library ttk.tcl]] + uplevel \#0 [list source $::ttk::library/ttk.tcl] } # Local Variables: |