>>  uu Byo `.;<4Bg<] tkpython.rsrc.crcpoolertAD MErlrsrcRSEDct0~=G .N^ _TONNV >(o.MgpBGlxBB`\~B`XP Z_VP B2 x)oP B0@VP Z2 >@`P BVP !!,P File Type:`p&H&JMIh @  ??o??HH }u }u]u]u&& . & !>???>HH1111O!!@!!/!/!!/!!DDDDDD`>c` 00 `>?HH:p雙e\陙ff\陙ff\5p feY\5pffz`((HHyJ!6UUc5Q533Q6UUa333333333""""x DDDDDD""""""UUUUUU wwwwww R`p @@HH@B/?R5S/25/ff33R` p 1qx0 p?x0 HH?C4?O4?_4?P_4?_4?_4?_4?_4?3P_4??O4?"ff33DDDDDDz`@ @?!9)9)99!!? ???????????HH `` 3`  wwwwwwUUUUUU""""""DDDDDD ffff `@@@9888 $H((0 ??|x@D~(>|x@~>|x@D`'XhP(ԯԠP(Xh'|?xxp8p8xx?D`'XhS(ԯԣS(Xh'|?xxs8s8xx?D|>>|>||>`p88pp88p`D|  8p p>`|`@p@ D @? D @?D` @DqQQQQqD @Ȁ @ DS3P0D @ @ D D ** D30#??wgD<<8pppp8<<?|>|>?D3dfIOD"c?)))+ix??????D 3p UzU6??DDBR* ~~ *RBCs;;sCDD "BB" >~~>D????????D?    !!    ???0 0 13310 0 ??D  ?;;?D <``@@ @>?8p@D <p   @>?p``8@p@@D?"D&d,48!!8,4&d"D??>|>|<<9##9<<>|>|?DGo|0HL~d$|88~?D11;;Dxp@6O~0|008?D? ˠ88>&& . & !>???>D </_Jb4 </~~< D?@ ?"A$P ??p D>c` 00 `>?DUU    UD?OgsyysgO?D  ``pD```abdodba```D  DDDETETETETDDD  D0000000 DC$Kp@@@ PxoonD@@```pppxxx|>8@??|~8 DD?x?88D?x?88DD@@@@@@@@@@@DD p 1qx0 p?x0 D@@@GD D"D"" 7777D   @@gg@@  p88p8pߟ8p8pp8D@ @?!9)9)99!!? ???????????D@@@9888 $H((0 ??? @ ??p8DȀ@  @ D3S0PD@ @ DD `    pp D D(I'0a @@D0000000 D D ` `  LOpenh|LCancelQ 4LEject<PLDesktop  [\M ,Uk( X` MDEFONNuH0O8/6$o&&|MDEFYO. T.UO> ?_UO> ?_ x \f x \ P/h/h Df6?//4//4//4/ HoN/! T?/1 ?/1 Df*Rg& x \g x \ P!o!o ! ! OL NtdD HHdD dDDdDHHZZ76554433f7635544337655f33310//f103//..ff10f//ff..f3--f103//3..3--3f1033//3..--10//f..3-+*))(('f+*3))((''+*))f((3''+*))((''f3GGFFfEEffGGffFFf3EEf3GG3FF3EE3f33AA3@@??CBAAf@@3??CBAA@@??fCB3AA@@??CBAAf@@3??CBAA@@??f=<3;;::f99f=<f;;ff::f399f=<3;;3::3993f=<33;;3::99=<;;f::399=p p0`1cc?? X ,## tk.tcl -- # # Initialization script normally executed in the interpreter for each # Tk-based application. Arranges class bindings for widgets. # # RCS: @(#) $Id: tk.tcl,v 1.20.2.2 2001/10/19 17:33:00 hobbs Exp $ # # Copyright (c) 1992-1994 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 1998-2000 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # Insist on running with compatible versions of Tcl and Tk. package require -exact Tk 8.3 package require -exact Tcl 8.3 # Add Tk's directory to the end of the auto-load search path, if it # isn't already on the path: if {[info exists auto_path] && [string compare {} $tk_library] && \ [lsearch -exact $auto_path $tk_library] < 0} { lappend auto_path $tk_library } # Turn off strict Motif look and feel as a default. set tk_strictMotif 0 # Turn on useinputmethods (X Input Methods) by default. # We catch this because safe interpreters may not allow the call. catch {tk useinputmethods 1} # Create a ::tk namespace namespace eval ::tk { } # ::tk::PlaceWindow -- # place a toplevel at a particular position # Arguments: # toplevel name of toplevel window # ?placement? pointer ?center? ; places $w centered on the pointer # widget widgetPath ; centers $w over widget_name # defaults to placing toplevel in the middle of the screen # ?anchor? center or widgetPath # Results: # Returns nothing # proc ::tk::PlaceWindow {w {place ""} {anchor ""}} { wm withdraw $w update idletasks set checkBounds 1 if {[string equal -len [string length $place] $place "pointer"]} { ## place at POINTER (centered if $anchor == center) if {[string equal -len [string length $anchor] $anchor "center"]} { set x [expr {[winfo pointerx $w]-[winfo reqwidth $w]/2}] set y [expr {[winfo pointery $w]-[winfo reqheight $w]/2}] } else { set x [winfo pointerx $w] set y [winfo pointery $w] } } elseif {[string equal -len [string length $place] $place "widget"] && \ [winfo exists $anchor] && [winfo ismapped $anchor]} { ## center about WIDGET $anchor, widget must be mapped set x [expr {[winfo rootx $anchor] + \ ([winfo width $anchor]-[winfo reqwidth $w])/2}] set y [expr {[winfo rooty $anchor] + \ ([winfo height $anchor]-[winfo reqheight $w])/2}] } else { set x [expr {([winfo screenwidth $w]-[winfo reqwidth $w])/2}] set y [expr {([winfo screenheight $w]-[winfo reqheight $w])/2}] set checkBounds 0 } if {$checkBounds} { if {$x < 0} { set x 0 } elseif {$x > ([winfo screenwidth $w]-[winfo reqwidth $w])} { set x [expr {[winfo screenwidth $w]-[winfo reqwidth $w]}] } if {$y < 0} { set y 0 } elseif {$y > ([winfo screenheight $w]-[winfo reqheight $w])} { set y [expr {[winfo screenheight $w]-[winfo reqheight $w]}] } } wm geometry $w +$x+$y wm deiconify $w } # ::tk::SetFocusGrab -- # swap out current focus and grab temporarily (for dialogs) # Arguments: # grab new window to grab # focus window to give focus to # Results: # Returns nothing # proc ::tk::SetFocusGrab {grab {focus {}}} { set index "$grab,$focus" upvar ::tk::FocusGrab($index) data lappend data [focus] set oldGrab [grab current $grab] lappend data $oldGrab if {[winfo exists $oldGrab]} { lappend data [grab status $oldGrab] } # The "grab" command will fail if another application # already holds the grab. So catch it. catch {grab $grab} if {[winfo exists $focus]} { focus $focus } } # ::tk::RestoreFocusGrab -- # restore old focus and grab (for dialogs) # Arguments: # grab window that had taken grab # focus window that had taken focus # destroy destroy|withdraw - how to handle the old grabbed window # Results: # Returns nothing # proc ::tk::RestoreFocusGrab {grab focus {destroy destroy}} { set index "$grab,$focus" foreach {oldFocus oldGrab oldStatus} $::tk::FocusGrab($index) { break } unset ::tk::FocusGrab($index) catch {focus $oldFocus} grab release $grab if {[string equal $destroy "withdraw"]} { wm withdraw $grab } else { destroy $grab } if {[winfo exists $oldGrab] && [winfo ismapped $oldGrab]} { if {[string equal $oldStatus "global"]} { grab -global $oldGrab } else { grab $oldGrab } } } # ::tk::GetSelection -- # This tries to obtain the default selection. # This shadows the 8.4 version which handles UTF8_STRING as well. # Arguments: # w The widget for which the selection will be retrieved. # Important for the -displayof property. # sel The source of the selection (PRIMARY or CLIPBOARD) # Results: # Returns the selection, or an error if none could be found # proc ::tk::GetSelection {w {sel PRIMARY}} { if {[catch {selection get -displayof $w -selection $sel} txt]} { return -code error "could not find default selection" } else { return $txt } } # tkScreenChanged -- # 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 global variable "tkPriv" 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 tkScreenChanged screen { set x [string last . $screen] if {$x > 0} { set disp [string range $screen 0 [expr {$x - 1}]] } else { set disp $screen } uplevel #0 upvar #0 tkPriv.$disp tkPriv global tkPriv global tcl_platform if {[info exists tkPriv]} { set tkPriv(screen) $screen return } array set tkPriv { activeMenu {} activeItem {} afterId {} buttons 0 buttonWindow {} dragging 0 focus {} grab {} initPos {} inMenubutton {} listboxPrev {} menuBar {} mouseMoved 0 oldGrab {} popup {} postedMb {} pressX 0 pressY 0 prevPos 0 selectMode char } set tkPriv(screen) $screen set tkPriv(tearoff) [string equal $tcl_platform(platform) "unix"] set tkPriv(window) {} } # Do initial setup for tkPriv, so that it is always bound to something # (otherwise, if someone references it, it may get set to a non-upvar-ed # value, which will cause trouble later). tkScreenChanged [winfo screen .] # tkEventMotifBindings -- # 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"). proc tkEventMotifBindings {n1 dummy dummy} { upvar $n1 name if {$name} { set op delete } else { set op add } event $op <> event $op <> event $op <> } #---------------------------------------------------------------------- # Define common dialogs on platforms where they are not implemented # using compiled code. #---------------------------------------------------------------------- if {[string equal [info commands tk_chooseColor] ""]} { proc tk_chooseColor {args} { return [eval tkColorDialog $args] } } if {[string equal [info commands tk_getOpenFile] ""]} { proc tk_getOpenFile {args} { if {$::tk_strictMotif} { return [eval tkMotifFDialog open $args] } else { return [eval ::tk::dialog::file::tkFDialog open $args] } } } if {[string equal [info commands tk_getSaveFile] ""]} { proc tk_getSaveFile {args} { if {$::tk_strictMotif} { return [eval tkMotifFDialog save $args] } else { return [eval ::tk::dialog::file::tkFDialog save $args] } } } if {[string equal [info commands tk_messageBox] ""]} { proc tk_messageBox {args} { return [eval tkMessageBox $args] } } if {[string equal [info command tk_chooseDirectory] ""]} { proc tk_chooseDirectory {args} { return [eval ::tk::dialog::file::chooseDir::tkChooseDirectory $args] } } #---------------------------------------------------------------------- # Define the set of common virtual events. #---------------------------------------------------------------------- switch $tcl_platform(platform) { "unix" { event add <> event add <> event add <> event add <> # Some OS's define a goofy (as in, not ) keysym # that is returned when the user presses . In order for # tab traversal to work, we have to add these keysyms to the # PrevWindow event. # The info exists is necessary, because tcl_platform(os) doesn't # exist in safe interpreters. if {[info exists tcl_platform(os)]} { switch $tcl_platform(os) { "IRIX" - "Linux" { event add <> } "HP-UX" { # This seems to be correct on *some* HP systems. catch { event add <> } } } } trace variable tk_strictMotif w tkEventMotifBindings set tk_strictMotif $tk_strictMotif } "windows" { event add <> event add <> event add <> event add <> } "macintosh" { event add <> event add <> event add <> event add <> event add <> } } # ---------------------------------------------------------------------- # Read in files that define all of the class bindings. # ---------------------------------------------------------------------- if {[string compare $tcl_platform(platform) "macintosh"] && \ [string compare {} $tk_library]} { source [file join $tk_library button.tcl] source [file join $tk_library entry.tcl] source [file join $tk_library listbox.tcl] source [file join $tk_library menu.tcl] source [file join $tk_library scale.tcl] source [file join $tk_library scrlbar.tcl] source [file join $tk_library text.tcl] } # ---------------------------------------------------------------------- # Default bindings for keyboard traversal. # ---------------------------------------------------------------------- event add <> bind all {tkTabToWindow [tk_focusNext %W]} bind all <> {tkTabToWindow [tk_focusPrev %W]} # tkCancelRepeat -- # This procedure is invoked to cancel an auto-repeat action described # by tkPriv(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. proc tkCancelRepeat {} { global tkPriv after cancel $tkPriv(afterId) set tkPriv(afterId) {} } # tkTabToWindow -- # This procedure moves the focus to the given widget. If the widget # is an entry, it selects the entire contents of the widget. # # Arguments: # w - Window to which focus should be set. proc tkTabToWindow {w} { if {[string equal [winfo class $w] Entry]} { $w selection range 0 end $w icursor end } focus $w } ,# button.tcl -- # # This file defines the default bindings for Tk label, button, # checkbutton, and radiobutton widgets and provides procedures # that help in implementing those bindings. # # RCS: @(#) $Id: button.tcl,v 1.6 1999/09/02 17:02:52 hobbs Exp $ # # Copyright (c) 1992-1994 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # #------------------------------------------------------------------------- # The code below creates the default class bindings for buttons. #------------------------------------------------------------------------- if {[string match "macintosh" $tcl_platform(platform)]} { bind Radiobutton { tkButtonEnter %W } bind Radiobutton <1> { tkButtonDown %W } bind Radiobutton { tkButtonUp %W } bind Checkbutton { tkButtonEnter %W } bind Checkbutton <1> { tkButtonDown %W } bind Checkbutton { tkButtonUp %W } } if {[string match "windows" $tcl_platform(platform)]} { bind Checkbutton { tkCheckRadioInvoke %W select } bind Checkbutton { tkCheckRadioInvoke %W select } bind Checkbutton { tkCheckRadioInvoke %W deselect } bind Checkbutton <1> { tkCheckRadioDown %W } bind Checkbutton { tkButtonUp %W } bind Checkbutton { tkCheckRadioEnter %W } bind Radiobutton <1> { tkCheckRadioDown %W } bind Radiobutton { tkButtonUp %W } bind Radiobutton { tkCheckRadioEnter %W } } if {[string match "unix" $tcl_platform(platform)]} { bind Checkbutton { if {!$tk_strictMotif} { tkCheckRadioInvoke %W } } bind Radiobutton { if {!$tk_strictMotif} { tkCheckRadioInvoke %W } } bind Checkbutton <1> { tkCheckRadioInvoke %W } bind Radiobutton <1> { tkCheckRadioInvoke %W } bind Checkbutton { tkButtonEnter %W } bind Radiobutton { tkButtonEnter %W } } bind Button { tkButtonInvoke %W } bind Checkbutton { tkCheckRadioInvoke %W } bind Radiobutton { tkCheckRadioInvoke %W } bind Button {} bind Button { tkButtonEnter %W } bind Button { tkButtonLeave %W } bind Button <1> { tkButtonDown %W } bind Button { tkButtonUp %W } bind Checkbutton {} bind Checkbutton { tkButtonLeave %W } bind Radiobutton {} bind Radiobutton { tkButtonLeave %W } if {[string match "windows" $tcl_platform(platform)]} { ######################### # Windows implementation ######################### # tkButtonEnter -- # The procedure below is invoked when the mouse pointer enters a # button widget. It records the button we're in and changes the # state of the button to active unless the button is disabled. # # Arguments: # w - The name of the widget. proc tkButtonEnter w { global tkPriv if {[string compare [$w cget -state] "disabled"] \ && [string equal $tkPriv(buttonWindow) $w]} { $w configure -state active -relief sunken } set tkPriv(window) $w } # tkButtonLeave -- # The procedure below is invoked when the mouse pointer leaves a # button widget. It changes the state of the button back to # inactive. If we're leaving the button window with a mouse button # pressed (tkPriv(buttonWindow) == $w), restore the relief of the # button too. # # Arguments: # w - The name of the widget. proc tkButtonLeave w { global tkPriv if {[string compare [$w cget -state] "disabled"]} { $w configure -state normal } if {[string equal $tkPriv(buttonWindow) $w]} { $w configure -relief $tkPriv(relief) } set tkPriv(window) "" } # tkCheckRadioEnter -- # The procedure below is invoked when the mouse pointer enters a # checkbutton or radiobutton widget. It records the button we're in # and changes the state of the button to active unless the button is # disabled. # # Arguments: # w - The name of the widget. proc tkCheckRadioEnter w { global tkPriv if {[string compare [$w cget -state] "disabled"] \ && [string equal $tkPriv(buttonWindow) $w]} { $w configure -state active } set tkPriv(window) $w } # tkButtonDown -- # The procedure below is invoked when the mouse button is pressed in # a button widget. It records the fact that the mouse is in the button, # saves the button's relief so it can be restored later, and changes # the relief to sunken. # # Arguments: # w - The name of the widget. proc tkButtonDown w { global tkPriv set tkPriv(relief) [$w cget -relief] if {[string compare [$w cget -state] "disabled"]} { set tkPriv(buttonWindow) $w $w configure -relief sunken -state active } } # tkCheckRadioDown -- # The procedure below is invoked when the mouse button is pressed in # a button widget. It records the fact that the mouse is in the button, # saves the button's relief so it can be restored later, and changes # the relief to sunken. # # Arguments: # w - The name of the widget. proc tkCheckRadioDown w { global tkPriv set tkPriv(relief) [$w cget -relief] if {[string compare [$w cget -state] "disabled"]} { set tkPriv(buttonWindow) $w $w configure -state active } } # tkButtonUp -- # The procedure below is invoked when the mouse button is released # in a button widget. It restores the button's relief and invokes # the command as long as the mouse hasn't left the button. # # Arguments: # w - The name of the widget. proc tkButtonUp w { global tkPriv if {[string equal $tkPriv(buttonWindow) $w]} { set tkPriv(buttonWindow) "" $w configure -relief $tkPriv(relief) if {[string equal $tkPriv(window) $w] && [string compare [$w cget -state] "disabled"]} { $w configure -state normal uplevel #0 [list $w invoke] } } } } if {[string match "unix" $tcl_platform(platform)]} { ##################### # Unix implementation ##################### # tkButtonEnter -- # The procedure below is invoked when the mouse pointer enters a # button widget. It records the button we're in and changes the # state of the button to active unless the button is disabled. # # Arguments: # w - The name of the widget. proc tkButtonEnter {w} { global tkPriv if {[string compare [$w cget -state] "disabled"]} { $w configure -state active if {[string equal $tkPriv(buttonWindow) $w]} { $w configure -state active -relief sunken } } set tkPriv(window) $w } # tkButtonLeave -- # The procedure below is invoked when the mouse pointer leaves a # button widget. It changes the state of the button back to # inactive. If we're leaving the button window with a mouse button # pressed (tkPriv(buttonWindow) == $w), restore the relief of the # button too. # # Arguments: # w - The name of the widget. proc tkButtonLeave w { global tkPriv if {[string compare [$w cget -state] "disabled"]} { $w configure -state normal } if {[string equal $tkPriv(buttonWindow) $w]} { $w configure -relief $tkPriv(relief) } set tkPriv(window) "" } # tkButtonDown -- # The procedure below is invoked when the mouse button is pressed in # a button widget. It records the fact that the mouse is in the button, # saves the button's relief so it can be restored later, and changes # the relief to sunken. # # Arguments: # w - The name of the widget. proc tkButtonDown w { global tkPriv set tkPriv(relief) [$w cget -relief] if {[string compare [$w cget -state] "disabled"]} { set tkPriv(buttonWindow) $w $w configure -relief sunken } } # tkButtonUp -- # The procedure below is invoked when the mouse button is released # in a button widget. It restores the button's relief and invokes # the command as long as the mouse hasn't left the button. # # Arguments: # w - The name of the widget. proc tkButtonUp w { global tkPriv if {[string equal $w $tkPriv(buttonWindow)]} { set tkPriv(buttonWindow) "" $w configure -relief $tkPriv(relief) if {[string equal $w $tkPriv(window)] \ && [string compare [$w cget -state] "disabled"]} { uplevel #0 [list $w invoke] } } } } if {[string match "macintosh" $tcl_platform(platform)]} { #################### # Mac implementation #################### # tkButtonEnter -- # The procedure below is invoked when the mouse pointer enters a # button widget. It records the button we're in and changes the # state of the button to active unless the button is disabled. # # Arguments: # w - The name of the widget. proc tkButtonEnter {w} { global tkPriv if {[string compare [$w cget -state] "disabled"]} { if {[string equal $w $tkPriv(buttonWindow)]} { $w configure -state active } } set tkPriv(window) $w } # tkButtonLeave -- # The procedure below is invoked when the mouse pointer leaves a # button widget. It changes the state of the button back to # inactive. If we're leaving the button window with a mouse button # pressed (tkPriv(buttonWindow) == $w), restore the relief of the # button too. # # Arguments: # w - The name of the widget. proc tkButtonLeave w { global tkPriv if {[string equal $w $tkPriv(buttonWindow)]} { $w configure -state normal } set tkPriv(window) "" } # tkButtonDown -- # The procedure below is invoked when the mouse button is pressed in # a button widget. It records the fact that the mouse is in the button, # saves the button's relief so it can be restored later, and changes # the relief to sunken. # # Arguments: # w - The name of the widget. proc tkButtonDown w { global tkPriv if {[string compare [$w cget -state] "disabled"]} { set tkPriv(buttonWindow) $w $w configure -state active } } # tkButtonUp -- # The procedure below is invoked when the mouse button is released # in a button widget. It restores the button's relief and invokes # the command as long as the mouse hasn't left the button. # # Arguments: # w - The name of the widget. proc tkButtonUp w { global tkPriv if {[string equal $w $tkPriv(buttonWindow)]} { $w configure -state normal set tkPriv(buttonWindow) "" if {[string equal $w $tkPriv(window)] && [string compare [$w cget -state] "disabled"]} { uplevel #0 [list $w invoke] } } } } ################## # Shared routines ################## # tkButtonInvoke -- # The procedure below is called when a button is invoked through # the keyboard. It simulate a press of the button via the mouse. # # Arguments: # w - The name of the widget. proc tkButtonInvoke w { if {[string compare [$w cget -state] "disabled"]} { set oldRelief [$w cget -relief] set oldState [$w cget -state] $w configure -state active -relief sunken update idletasks after 100 $w configure -state $oldState -relief $oldRelief uplevel #0 [list $w invoke] } } # tkCheckRadioInvoke -- # The procedure below is invoked when the mouse button is pressed in # a checkbutton or radiobutton widget, or when the widget is invoked # through the keyboard. It invokes the widget if it # isn't disabled. # # Arguments: # w - The name of the widget. # cmd - The subcommand to invoke (one of invoke, select, or deselect). proc tkCheckRadioInvoke {w {cmd invoke}} { if {[string compare [$w cget -state] "disabled"]} { uplevel #0 [list $w $cmd] } } J# dialog.tcl -- # # This file defines the procedure tk_dialog, which creates a dialog # box containing a bitmap, a message, and one or more buttons. # # RCS: @(#) $Id: dialog.tcl,v 1.8 2000/04/18 02:18:33 ericm Exp $ # # Copyright (c) 1992-1993 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # # tk_dialog: # # This procedure displays a dialog box, waits for a button in the dialog # to be invoked, then returns the index of the selected button. If the # dialog somehow gets destroyed, -1 is returned. # # Arguments: # w - Window to use for dialog top-level. # title - Title to display in dialog's decorative frame. # text - Message to display in dialog. # bitmap - Bitmap to display in dialog (empty string means none). # default - Index of button that is to display the default ring # (-1 means none). # args - One or more strings to display in buttons across the # bottom of the dialog box. proc tk_dialog {w title text bitmap default args} { global tkPriv tcl_platform # Check that $default was properly given if {[string is int $default]} { if {$default >= [llength $args]} { return -code error "default button index greater than number of\ buttons specified for tk_dialog" } } elseif {[string equal {} $default]} { set default -1 } else { set default [lsearch -exact $args $default] } # 1. Create the top-level window and divide it into top # and bottom parts. catch {destroy $w} toplevel $w -class Dialog wm title $w $title wm iconname $w Dialog wm protocol $w WM_DELETE_WINDOW { } # Dialog boxes should be transient with respect to their parent, # so that they will always stay on top of their parent window. However, # some window managers will create the window as withdrawn if the parent # window is withdrawn or iconified. Combined with the grab we put on the # window, this can hang the entire application. Therefore we only make # the dialog transient if the parent is viewable. # if { [winfo viewable [winfo toplevel [winfo parent $w]]] } { wm transient $w [winfo toplevel [winfo parent $w]] } if {[string equal $tcl_platform(platform) "macintosh"]} { unsupported1 style $w dBoxProc } frame $w.bot frame $w.top if {[string equal $tcl_platform(platform) "unix"]} { $w.bot configure -relief raised -bd 1 $w.top configure -relief raised -bd 1 } pack $w.bot -side bottom -fill both pack $w.top -side top -fill both -expand 1 # 2. Fill the top part with bitmap and message (use the option # database for -wraplength and -font so that they can be # overridden by the caller). option add *Dialog.msg.wrapLength 3i widgetDefault if {[string equal $tcl_platform(platform) "macintosh"]} { option add *Dialog.msg.font system widgetDefault } else { option add *Dialog.msg.font {Times 12} widgetDefault } label $w.msg -justify left -text $text pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m if {[string compare $bitmap ""]} { if {[string equal $tcl_platform(platform) "macintosh"] && \ [string equal $bitmap "error"]} { set bitmap "stop" } label $w.bitmap -bitmap $bitmap pack $w.bitmap -in $w.top -side left -padx 3m -pady 3m } # 3. Create a row of buttons at the bottom of the dialog. set i 0 foreach but $args { button $w.button$i -text $but -command [list set tkPriv(button) $i] if {$i == $default} { $w.button$i configure -default active } else { $w.button$i configure -default normal } grid $w.button$i -in $w.bot -column $i -row 0 -sticky ew -padx 10 grid columnconfigure $w.bot $i # We boost the size of some Mac buttons for l&f if {[string equal $tcl_platform(platform) "macintosh"]} { set tmp [string tolower $but] if {[string equal $tmp "ok"] || [string equal $tmp "cancel"]} { grid columnconfigure $w.bot $i -minsize [expr {59 + 20}] } } incr i } # 4. Create a binding for on the dialog if there is a # default button. if {$default >= 0} { bind $w " [list $w.button$default] configure -state active -relief sunken update idletasks after 100 set tkPriv(button) $default " } # 5. Create a binding for the window that sets the # button variable to -1; this is needed in case something happens # that destroys the window, such as its parent window being destroyed. bind $w {set tkPriv(button) -1} # 6. Withdraw the window, then update all the geometry information # so we know how big it wants to be, then center the window in the # display and de-iconify it. wm withdraw $w update idletasks set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \ - [winfo vrootx [winfo parent $w]]}] set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2 \ - [winfo vrooty [winfo parent $w]]}] wm geom $w +$x+$y wm deiconify $w # 7. Set a grab and claim the focus too. set oldFocus [focus] set oldGrab [grab current $w] if {[string compare $oldGrab ""]} { set grabStatus [grab status $oldGrab] } grab $w if {$default >= 0} { focus $w.button$default } else { focus $w } # 8. Wait for the user to respond, then restore the focus and # return the index of the selected button. Restore the focus # before deleting the window, since otherwise the window manager # may take the focus away so we can't redirect it. Finally, # restore any grab that was in effect. tkwait variable tkPriv(button) catch {focus $oldFocus} catch { # It's possible that the window has already been destroyed, # hence this "catch". Delete the Destroy handler so that # tkPriv(button) doesn't get reset by it. bind $w {} destroy $w } if {[string compare $oldGrab ""]} { if {[string compare $grabStatus "global"]} { grab $oldGrab } else { grab -global $oldGrab } } return $tkPriv(button) } >C# entry.tcl -- # # This file defines the default bindings for Tk entry widgets and provides # procedures that help in implementing those bindings. # # RCS: @(#) $Id: entry.tcl,v 1.11.2.1 2001/04/04 07:57:17 hobbs Exp $ # # Copyright (c) 1992-1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # #------------------------------------------------------------------------- # Elements of tkPriv that are used in this file: # # afterId - If non-null, it means that auto-scanning is underway # and it gives the "after" id for the next auto-scan # command to be executed. # mouseMoved - Non-zero means the mouse has moved a significant # amount since the button went down (so, for example, # start dragging out a selection). # pressX - X-coordinate at which the mouse button was pressed. # selectMode - The style of selection currently underway: # char, word, or line. # x, y - Last known mouse coordinates for scanning # and auto-scanning. # data - Used for Cut and Copy #------------------------------------------------------------------------- #------------------------------------------------------------------------- # The code below creates the default class bindings for entries. #------------------------------------------------------------------------- bind Entry <> { if {![catch {tkEntryGetSelection %W} tkPriv(data)]} { clipboard clear -displayof %W clipboard append -displayof %W $tkPriv(data) %W delete sel.first sel.last unset tkPriv(data) } } bind Entry <> { if {![catch {tkEntryGetSelection %W} tkPriv(data)]} { clipboard clear -displayof %W clipboard append -displayof %W $tkPriv(data) unset tkPriv(data) } } bind Entry <> { global tcl_platform catch { if {[string compare $tcl_platform(platform) "unix"]} { catch { %W delete sel.first sel.last } } %W insert insert [selection get -displayof %W -selection CLIPBOARD] tkEntrySeeInsert %W } } bind Entry <> { %W delete sel.first sel.last } bind Entry <> { if {!$tkPriv(mouseMoved) || $tk_strictMotif} { tkEntryPaste %W %x } } # Standard Motif bindings: bind Entry <1> { tkEntryButton1 %W %x %W selection clear } bind Entry { set tkPriv(x) %x tkEntryMouseSelect %W %x } bind Entry { set tkPriv(selectMode) word tkEntryMouseSelect %W %x catch {%W icursor sel.first} } bind Entry { set tkPriv(selectMode) line tkEntryMouseSelect %W %x %W icursor 0 } bind Entry { set tkPriv(selectMode) char %W selection adjust @%x } bind Entry { set tkPriv(selectMode) word tkEntryMouseSelect %W %x } bind Entry { set tkPriv(selectMode) line tkEntryMouseSelect %W %x } bind Entry { set tkPriv(x) %x tkEntryAutoScan %W } bind Entry { tkCancelRepeat } bind Entry { tkCancelRepeat } bind Entry { %W icursor @%x } bind Entry { tkEntrySetCursor %W [expr {[%W index insert] - 1}] } bind Entry { tkEntrySetCursor %W [expr {[%W index insert] + 1}] } bind Entry { tkEntryKeySelect %W [expr {[%W index insert] - 1}] tkEntrySeeInsert %W } bind Entry { tkEntryKeySelect %W [expr {[%W index insert] + 1}] tkEntrySeeInsert %W } bind Entry { tkEntrySetCursor %W [tkEntryPreviousWord %W insert] } bind Entry { tkEntrySetCursor %W [tkEntryNextWord %W insert] } bind Entry { tkEntryKeySelect %W [tkEntryPreviousWord %W insert] tkEntrySeeInsert %W } bind Entry { tkEntryKeySelect %W [tkEntryNextWord %W insert] tkEntrySeeInsert %W } bind Entry { tkEntrySetCursor %W 0 } bind Entry { tkEntryKeySelect %W 0 tkEntrySeeInsert %W } bind Entry { tkEntrySetCursor %W end } bind Entry { tkEntryKeySelect %W end tkEntrySeeInsert %W } bind Entry { if {[%W selection present]} { %W delete sel.first sel.last } else { %W delete insert } } bind Entry { tkEntryBackspace %W } bind Entry { %W selection from insert } bind Entry { tkListboxBeginSelect %W [%W index active] } bind Listbox { tkListboxBeginExtend %W [%W index active] } bind Listbox { tkListboxBeginExtend %W [%W index active] } bind Listbox { tkListboxCancel %W } bind Listbox { tkListboxSelectAll %W } bind Listbox { if {[string compare [%W cget -selectmode] "browse"]} { %W selection clear 0 end event generate %W <> } } # Additional Tk bindings that aren't part of the Motif look and feel: bind Listbox <2> { %W scan mark %x %y } bind Listbox { %W scan dragto %x %y } # The MouseWheel will typically only fire on Windows. However, # someone could use the "event generate" command to produce one # on other platforms. bind Listbox { %W yview scroll [expr {- (%D / 120) * 4}] units } if {[string equal "unix" $tcl_platform(platform)]} { # Support for mousewheels on Linux/Unix commonly comes through mapping # the wheel to the extended buttons. If you have a mousewheel, find # Linux configuration info at: # http://www.inria.fr/koala/colas/mouse-wheel-scroll/ bind Listbox <4> { if {!$tk_strictMotif} { %W yview scroll -5 units } } bind Listbox <5> { if {!$tk_strictMotif} { %W yview scroll 5 units } } } # tkListboxBeginSelect -- # # This procedure is typically invoked on button-1 presses. It begins # the process of making a selection in the listbox. Its exact behavior # depends on the selection mode currently in effect for the listbox; # see the Motif documentation for details. # # Arguments: # w - The listbox widget. # el - The element for the selection operation (typically the # one under the pointer). Must be in numerical form. proc tkListboxBeginSelect {w el} { global tkPriv if {[string equal [$w cget -selectmode] "multiple"]} { if {[$w selection includes $el]} { $w selection clear $el } else { $w selection set $el } } else { $w selection clear 0 end $w selection set $el $w selection anchor $el set tkPriv(listboxSelection) {} set tkPriv(listboxPrev) $el } event generate $w <> } # tkListboxMotion -- # # This procedure is called to process mouse motion events while # button 1 is down. It may move or extend the selection, depending # on the listbox's selection mode. # # Arguments: # w - The listbox widget. # el - The element under the pointer (must be a number). proc tkListboxMotion {w el} { global tkPriv if {$el == $tkPriv(listboxPrev)} { return } set anchor [$w index anchor] switch [$w cget -selectmode] { browse { $w selection clear 0 end $w selection set $el set tkPriv(listboxPrev) $el event generate $w <> } extended { set i $tkPriv(listboxPrev) if {[string equal {} $i]} { set i $el $w selection set $el } if {[$w selection includes anchor]} { $w selection clear $i $el $w selection set anchor $el } else { $w selection clear $i $el $w selection clear anchor $el } if {![info exists tkPriv(listboxSelection)]} { set tkPriv(listboxSelection) [$w curselection] } while {($i < $el) && ($i < $anchor)} { if {[lsearch $tkPriv(listboxSelection) $i] >= 0} { $w selection set $i } incr i } while {($i > $el) && ($i > $anchor)} { if {[lsearch $tkPriv(listboxSelection) $i] >= 0} { $w selection set $i } incr i -1 } set tkPriv(listboxPrev) $el event generate $w <> } } } # tkListboxBeginExtend -- # # This procedure is typically invoked on shift-button-1 presses. It # begins the process of extending a selection in the listbox. Its # exact behavior depends on the selection mode currently in effect # for the listbox; see the Motif documentation for details. # # Arguments: # w - The listbox widget. # el - The element for the selection operation (typically the # one under the pointer). Must be in numerical form. proc tkListboxBeginExtend {w el} { if {[string equal [$w cget -selectmode] "extended"]} { if {[$w selection includes anchor]} { tkListboxMotion $w $el } else { # No selection yet; simulate the begin-select operation. tkListboxBeginSelect $w $el } } } # tkListboxBeginToggle -- # # This procedure is typically invoked on control-button-1 presses. It # begins the process of toggling a selection in the listbox. Its # exact behavior depends on the selection mode currently in effect # for the listbox; see the Motif documentation for details. # # Arguments: # w - The listbox widget. # el - The element for the selection operation (typically the # one under the pointer). Must be in numerical form. proc tkListboxBeginToggle {w el} { global tkPriv if {[string equal [$w cget -selectmode] "extended"]} { set tkPriv(listboxSelection) [$w curselection] set tkPriv(listboxPrev) $el $w selection anchor $el if {[$w selection includes $el]} { $w selection clear $el } else { $w selection set $el } event generate $w <> } } # tkListboxAutoScan -- # This procedure is invoked when the mouse leaves an entry window # with button 1 down. It scrolls the window up, down, left, or # right, depending on where the mouse left the window, and reschedules # itself as an "after" command so that the window continues to scroll until # the mouse moves back into the window or the mouse button is released. # # Arguments: # w - The entry window. proc tkListboxAutoScan {w} { global tkPriv if {![winfo exists $w]} return set x $tkPriv(x) set y $tkPriv(y) if {$y >= [winfo height $w]} { $w yview scroll 1 units } elseif {$y < 0} { $w yview scroll -1 units } elseif {$x >= [winfo width $w]} { $w xview scroll 2 units } elseif {$x < 0} { $w xview scroll -2 units } else { return } tkListboxMotion $w [$w index @$x,$y] set tkPriv(afterId) [after 50 [list tkListboxAutoScan $w]] } # tkListboxUpDown -- # # Moves the location cursor (active element) up or down by one element, # and changes the selection if we're in browse or extended selection # mode. # # Arguments: # w - The listbox widget. # amount - +1 to move down one item, -1 to move back one item. proc tkListboxUpDown {w amount} { global tkPriv $w activate [expr {[$w index active] + $amount}] $w see active switch [$w cget -selectmode] { browse { $w selection clear 0 end $w selection set active event generate $w <> } extended { $w selection clear 0 end $w selection set active $w selection anchor active set tkPriv(listboxPrev) [$w index active] set tkPriv(listboxSelection) {} event generate $w <> } } } # tkListboxExtendUpDown -- # # Does nothing unless we're in extended selection mode; in this # case it moves the location cursor (active element) up or down by # one element, and extends the selection to that point. # # Arguments: # w - The listbox widget. # amount - +1 to move down one item, -1 to move back one item. proc tkListboxExtendUpDown {w amount} { if {[string compare [$w cget -selectmode] "extended"]} { return } set active [$w index active] if {![info exists tkPriv(listboxSelection)]} { global tkPriv $w selection set $active set tkPriv(listboxSelection) [$w curselection] } $w activate [expr {$active + $amount}] $w see active tkListboxMotion $w [$w index active] } # tkListboxDataExtend # # This procedure is called for key-presses such as Shift-KEndData. # If the selection mode isn't multiple or extend then it does nothing. # Otherwise it moves the active element to el and, if we're in # extended mode, extends the selection to that point. # # Arguments: # w - The listbox widget. # el - An integer element number. proc tkListboxDataExtend {w el} { set mode [$w cget -selectmode] if {[string equal $mode "extended"]} { $w activate $el $w see $el if {[$w selection includes anchor]} { tkListboxMotion $w $el } } elseif {[string equal $mode "multiple"]} { $w activate $el $w see $el } } # tkListboxCancel # # This procedure is invoked to cancel an extended selection in # progress. If there is an extended selection in progress, it # restores all of the items between the active one and the anchor # to their previous selection state. # # Arguments: # w - The listbox widget. proc tkListboxCancel w { global tkPriv if {[string compare [$w cget -selectmode] "extended"]} { return } set first [$w index anchor] set last $tkPriv(listboxPrev) if { [string equal $last ""] } { # Not actually doing any selection right now return } if {$first > $last} { set tmp $first set first $last set last $tmp } $w selection clear $first $last while {$first <= $last} { if {[lsearch $tkPriv(listboxSelection) $first] >= 0} { $w selection set $first } incr first } event generate $w <> } # tkListboxSelectAll # # This procedure is invoked to handle the "select all" operation. # For single and browse mode, it just selects the active element. # Otherwise it selects everything in the widget. # # Arguments: # w - The listbox widget. proc tkListboxSelectAll w { set mode [$w cget -selectmode] if {[string equal $mode "single"] || [string equal $mode "browse"]} { $w selection clear 0 end $w selection set active } else { $w selection set 0 end } event generate $w <> } # menu.tcl -- # # This file defines the default bindings for Tk menus and menubuttons. # It also implements keyboard traversal of menus and implements a few # other utility procedures related to menus. # # RCS: @(#) $Id: menu.tcl,v 1.12 2000/04/17 19:32:00 ericm Exp $ # # Copyright (c) 1992-1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # #------------------------------------------------------------------------- # Elements of tkPriv that are used in this file: # # cursor - Saves the -cursor option for the posted menubutton. # focus - Saves the focus during a menu selection operation. # Focus gets restored here when the menu is unposted. # grabGlobal - Used in conjunction with tkPriv(oldGrab): if # tkPriv(oldGrab) is non-empty, then tkPriv(grabGlobal) # contains either an empty string or "-global" to # indicate whether the old grab was a local one or # a global one. # inMenubutton - The name of the menubutton widget containing # the mouse, or an empty string if the mouse is # not over any menubutton. # menuBar - The name of the menubar that is the root # of the cascade hierarchy which is currently # posted. This is null when there is no menu currently # being pulled down from a menu bar. # oldGrab - Window that had the grab before a menu was posted. # Used to restore the grab state after the menu # is unposted. Empty string means there was no # grab previously set. # popup - If a menu has been popped up via tk_popup, this # gives the name of the menu. Otherwise this # value is empty. # postedMb - Name of the menubutton whose menu is currently # posted, or an empty string if nothing is posted # A grab is set on this widget. # relief - Used to save the original relief of the current # menubutton. # window - When the mouse is over a menu, this holds the # name of the menu; it's cleared when the mouse # leaves the menu. # tearoff - Whether the last menu posted was a tearoff or not. # This is true always for unix, for tearoffs for Mac # and Windows. # activeMenu - This is the last active menu for use # with the <> virtual event. # activeItem - This is the last active menu item for # use with the <> virtual event. #------------------------------------------------------------------------- #------------------------------------------------------------------------- # Overall note: # This file is tricky because there are five different ways that menus # can be used: # # 1. As a pulldown from a menubutton. In this style, the variable # tkPriv(postedMb) identifies the posted menubutton. # 2. As a torn-off menu copied from some other menu. In this style # tkPriv(postedMb) is empty, and menu's type is "tearoff". # 3. As an option menu, triggered from an option menubutton. In this # style tkPriv(postedMb) identifies the posted menubutton. # 4. As a popup menu. In this style tkPriv(postedMb) is empty and # the top-level menu's type is "normal". # 5. As a pulldown from a menubar. The variable tkPriv(menubar) has # the owning menubar, and the menu itself is of type "normal". # # The various binding procedures use the state described above to # distinguish the various cases and take different actions in each # case. #------------------------------------------------------------------------- #------------------------------------------------------------------------- # The code below creates the default class bindings for menus # and menubuttons. #------------------------------------------------------------------------- bind Menubutton {} bind Menubutton { tkMbEnter %W } bind Menubutton { tkMbLeave %W } bind Menubutton <1> { if {[string compare $tkPriv(inMenubutton) ""]} { tkMbPost $tkPriv(inMenubutton) %X %Y } } bind Menubutton { tkMbMotion %W up %X %Y } bind Menubutton { tkMbMotion %W down %X %Y } bind Menubutton { tkMbButtonUp %W } bind Menubutton { tkMbPost %W tkMenuFirstEntry [%W cget -menu] } # Must set focus when mouse enters a menu, in order to allow # mixed-mode processing using both the mouse and the keyboard. # Don't set the focus if the event comes from a grab release, # though: such an event can happen after as part of unposting # a cascaded chain of menus, after the focus has already been # restored to wherever it was before menu selection started. bind Menu {} bind Menu { set tkPriv(window) %W if {[string equal [%W cget -type] "tearoff"]} { if {[string compare "%m" "NotifyUngrab"]} { if {[string equal $tcl_platform(platform) "unix"]} { tk_menuSetFocus %W } } } tkMenuMotion %W %x %y %s } bind Menu { tkMenuLeave %W %X %Y %s } bind Menu { tkMenuMotion %W %x %y %s } bind Menu { tkMenuButtonDown %W } bind Menu { tkMenuInvoke %W 1 } bind Menu { tkMenuInvoke %W 0 } bind Menu { tkMenuInvoke %W 0 } bind Menu { tkMenuEscape %W } bind Menu { tkMenuLeftArrow %W } bind Menu { tkMenuRightArrow %W } bind Menu { tkMenuUpArrow %W } bind Menu { tkMenuDownArrow %W } bind Menu { tkTraverseWithinMenu %W %A } # The following bindings apply to all windows, and are used to # implement keyboard menu traversal. if {[string equal $tcl_platform(platform) "unix"]} { bind all { tkTraverseToMenu %W %A } bind all { tkFirstMenu %W } } else { bind Menubutton { tkTraverseToMenu %W %A } bind Menubutton { tkFirstMenu %W } } # tkMbEnter -- # This procedure is invoked when the mouse enters a menubutton # widget. It activates the widget unless it is disabled. Note: # this procedure is only invoked when mouse button 1 is *not* down. # The procedure tkMbB1Enter is invoked if the button is down. # # Arguments: # w - The name of the widget. proc tkMbEnter w { global tkPriv if {[string compare $tkPriv(inMenubutton) ""]} { tkMbLeave $tkPriv(inMenubutton) } set tkPriv(inMenubutton) $w if {[string compare [$w cget -state] "disabled"]} { $w configure -state active } } # tkMbLeave -- # This procedure is invoked when the mouse leaves a menubutton widget. # It de-activates the widget, if the widget still exists. # # Arguments: # w - The name of the widget. proc tkMbLeave w { global tkPriv set tkPriv(inMenubutton) {} if {![winfo exists $w]} { return } if {[string equal [$w cget -state] "active"]} { $w configure -state normal } } # tkMbPost -- # Given a menubutton, this procedure does all the work of posting # its associated menu and unposting any other menu that is currently # posted. # # Arguments: # w - The name of the menubutton widget whose menu # is to be posted. # x, y - Root coordinates of cursor, used for positioning # option menus. If not specified, then the center # of the menubutton is used for an option menu. proc tkMbPost {w {x {}} {y {}}} { global tkPriv errorInfo global tcl_platform if {[string equal [$w cget -state] "disabled"] || \ [string equal $w $tkPriv(postedMb)]} { return } set menu [$w cget -menu] if {[string equal $menu ""]} { return } set tearoff [expr {[string equal $tcl_platform(platform) "unix"] \ || [string equal [$menu cget -type] "tearoff"]}] if {[string first $w $menu] != 0} { error "can't post $menu: it isn't a descendant of $w (this is a new requirement in Tk versions 3.0 and later)" } set cur $tkPriv(postedMb) if {[string compare $cur ""]} { tkMenuUnpost {} } set tkPriv(cursor) [$w cget -cursor] set tkPriv(relief) [$w cget -relief] $w configure -cursor arrow $w configure -relief raised set tkPriv(postedMb) $w set tkPriv(focus) [focus] $menu activate none tkGenerateMenuSelect $menu # If this looks like an option menubutton then post the menu so # that the current entry is on top of the mouse. Otherwise post # the menu just below the menubutton, as for a pull-down. update idletasks if {[catch { switch [$w cget -direction] { above { set x [winfo rootx $w] set y [expr {[winfo rooty $w] - [winfo reqheight $menu]}] $menu post $x $y } below { set x [winfo rootx $w] set y [expr {[winfo rooty $w] + [winfo height $w]}] $menu post $x $y } left { set x [expr {[winfo rootx $w] - [winfo reqwidth $menu]}] set y [expr {(2 * [winfo rooty $w] + [winfo height $w]) / 2}] set entry [tkMenuFindName $menu [$w cget -text]] if {[$w cget -indicatoron]} { if {$entry == [$menu index last]} { incr y [expr {-([$menu yposition $entry] \ + [winfo reqheight $menu])/2}] } else { incr y [expr {-([$menu yposition $entry] \ + [$menu yposition [expr {$entry+1}]])/2}] } } $menu post $x $y if {[string compare $entry {}] && [string compare [$menu entrycget $entry -state] "disabled"]} { $menu activate $entry tkGenerateMenuSelect $menu } } right { set x [expr {[winfo rootx $w] + [winfo width $w]}] set y [expr {(2 * [winfo rooty $w] + [winfo height $w]) / 2}] set entry [tkMenuFindName $menu [$w cget -text]] if {[$w cget -indicatoron]} { if {$entry == [$menu index last]} { incr y [expr {-([$menu yposition $entry] \ + [winfo reqheight $menu])/2}] } else { incr y [expr {-([$menu yposition $entry] \ + [$menu yposition [expr {$entry+1}]])/2}] } } $menu post $x $y if {[string compare $entry {}] && [string compare [$menu entrycget $entry -state] "disabled"]} { $menu activate $entry tkGenerateMenuSelect $menu } } default { if {[$w cget -indicatoron]} { if {[string equal $y {}]} { set x [expr {[winfo rootx $w] + [winfo width $w]/2}] set y [expr {[winfo rooty $w] + [winfo height $w]/2}] } tkPostOverPoint $menu $x $y [tkMenuFindName $menu [$w cget -text]] } else { $menu post [winfo rootx $w] [expr {[winfo rooty $w]+[winfo height $w]}] } } } } msg]} { # Error posting menu (e.g. bogus -postcommand). Unpost it and # reflect the error. set savedInfo $errorInfo tkMenuUnpost {} error $msg $savedInfo } set tkPriv(tearoff) $tearoff if {$tearoff != 0} { focus $menu if {[winfo viewable $w]} { tkSaveGrabInfo $w grab -global $w } } } # tkMenuUnpost -- # This procedure unposts a given menu, plus all of its ancestors up # to (and including) a menubutton, if any. It also restores various # values to what they were before the menu was posted, and releases # a grab if there's a menubutton involved. Special notes: # 1. It's important to unpost all menus before releasing the grab, so # that any Enter-Leave events (e.g. from menu back to main # application) have mode NotifyGrab. # 2. Be sure to enclose various groups of commands in "catch" so that # the procedure will complete even if the menubutton or the menu # or the grab window has been deleted. # # Arguments: # menu - Name of a menu to unpost. Ignored if there # is a posted menubutton. proc tkMenuUnpost menu { global tcl_platform global tkPriv set mb $tkPriv(postedMb) # Restore focus right away (otherwise X will take focus away when # the menu is unmapped and under some window managers (e.g. olvwm) # we'll lose the focus completely). catch {focus $tkPriv(focus)} set tkPriv(focus) "" # Unpost menu(s) and restore some stuff that's dependent on # what was posted. catch { if {[string compare $mb ""]} { set menu [$mb cget -menu] $menu unpost set tkPriv(postedMb) {} $mb configure -cursor $tkPriv(cursor) $mb configure -relief $tkPriv(relief) } elseif {[string compare $tkPriv(popup) ""]} { $tkPriv(popup) unpost set tkPriv(popup) {} } elseif {[string compare [$menu cget -type] "menubar"] \ && [string compare [$menu cget -type] "tearoff"]} { # We're in a cascaded sub-menu from a torn-off menu or popup. # Unpost all the menus up to the toplevel one (but not # including the top-level torn-off one) and deactivate the # top-level torn off menu if there is one. while {1} { set parent [winfo parent $menu] if {[string compare [winfo class $parent] "Menu"] \ || ![winfo ismapped $parent]} { break } $parent activate none $parent postcascade none tkGenerateMenuSelect $parent set type [$parent cget -type] if {[string equal $type "menubar"] || \ [string equal $type "tearoff"]} { break } set menu $parent } if {[string compare [$menu cget -type] "menubar"]} { $menu unpost } } } if {($tkPriv(tearoff) != 0) || [string compare $tkPriv(menuBar) ""]} { # Release grab, if any, and restore the previous grab, if there # was one. if {[string compare $menu ""]} { set grab [grab current $menu] if {[string compare $grab ""]} { grab release $grab } } tkRestoreOldGrab if {[string compare $tkPriv(menuBar) ""]} { $tkPriv(menuBar) configure -cursor $tkPriv(cursor) set tkPriv(menuBar) {} } if {[string compare $tcl_platform(platform) "unix"]} { set tkPriv(tearoff) 0 } } } # tkMbMotion -- # This procedure handles mouse motion events inside menubuttons, and # also outside menubuttons when a menubutton has a grab (e.g. when a # menu selection operation is in progress). # # Arguments: # w - The name of the menubutton widget. # upDown - "down" means button 1 is pressed, "up" means # it isn't. # rootx, rooty - Coordinates of mouse, in (virtual?) root window. proc tkMbMotion {w upDown rootx rooty} { global tkPriv if {[string equal $tkPriv(inMenubutton) $w]} { return } set new [winfo containing $rootx $rooty] if {[string compare $new $tkPriv(inMenubutton)] \ && ([string equal $new ""] \ || [string equal [winfo toplevel $new] [winfo toplevel $w]])} { if {[string compare $tkPriv(inMenubutton) ""]} { tkMbLeave $tkPriv(inMenubutton) } if {[string compare $new ""] \ && [string equal [winfo class $new] "Menubutton"] \ && ([$new cget -indicatoron] == 0) \ && ([$w cget -indicatoron] == 0)} { if {[string equal $upDown "down"]} { tkMbPost $new $rootx $rooty } else { tkMbEnter $new } } } } # tkMbButtonUp -- # This procedure is invoked to handle button 1 releases for menubuttons. # If the release happens inside the menubutton then leave its menu # posted with element 0 activated. Otherwise, unpost the menu. # # Arguments: # w - The name of the menubutton widget. proc tkMbButtonUp w { global tkPriv global tcl_platform set menu [$w cget -menu] set tearoff [expr {[string equal $tcl_platform(platform) "unix"] || \ ([string compare $menu {}] && \ [string equal [$menu cget -type] "tearoff"])}] if {($tearoff != 0) && [string equal $tkPriv(postedMb) $w] \ && [string equal $tkPriv(inMenubutton) $w]} { tkMenuFirstEntry [$tkPriv(postedMb) cget -menu] } else { tkMenuUnpost {} } } # tkMenuMotion -- # This procedure is called to handle mouse motion events for menus. # It does two things. First, it resets the active element in the # menu, if the mouse is over the menu. Second, if a mouse button # is down, it posts and unposts cascade entries to match the mouse # position. # # Arguments: # menu - The menu window. # x - The x position of the mouse. # y - The y position of the mouse. # state - Modifier state (tells whether buttons are down). proc tkMenuMotion {menu x y state} { global tkPriv if {[string equal $menu $tkPriv(window)]} { if {[string equal [$menu cget -type] "menubar"]} { if {[info exists tkPriv(focus)] && \ [string compare $menu $tkPriv(focus)]} { $menu activate @$x,$y tkGenerateMenuSelect $menu } } else { $menu activate @$x,$y tkGenerateMenuSelect $menu } } if {($state & 0x1f00) != 0} { $menu postcascade active } } # tkMenuButtonDown -- # Handles button presses in menus. There are a couple of tricky things # here: # 1. Change the posted cascade entry (if any) to match the mouse position. # 2. If there is a posted menubutton, must grab to the menubutton; this # overrrides the implicit grab on button press, so that the menu # button can track mouse motions over other menubuttons and change # the posted menu. # 3. If there's no posted menubutton (e.g. because we're a torn-off menu # or one of its descendants) must grab to the top-level menu so that # we can track mouse motions across the entire menu hierarchy. # # Arguments: # menu - The menu window. proc tkMenuButtonDown menu { global tkPriv global tcl_platform if {![winfo viewable $menu]} { return } $menu postcascade active if {[string compare $tkPriv(postedMb) ""] && \ [winfo viewable $tkPriv(postedMb)]} { grab -global $tkPriv(postedMb) } else { while {[string equal [$menu cget -type] "normal"] \ && [string equal [winfo class [winfo parent $menu]] "Menu"] \ && [winfo ismapped [winfo parent $menu]]} { set menu [winfo parent $menu] } if {[string equal $tkPriv(menuBar) {}]} { set tkPriv(menuBar) $menu set tkPriv(cursor) [$menu cget -cursor] $menu configure -cursor arrow } # Don't update grab information if the grab window isn't changing. # Otherwise, we'll get an error when we unpost the menus and # restore the grab, since the old grab window will not be viewable # anymore. if {[string compare $menu [grab current $menu]]} { tkSaveGrabInfo $menu } # Must re-grab even if the grab window hasn't changed, in order # to release the implicit grab from the button press. if {[string equal $tcl_platform(platform) "unix"]} { grab -global $menu } } } # tkMenuLeave -- # This procedure is invoked to handle Leave events for a menu. It # deactivates everything unless the active element is a cascade element # and the mouse is now over the submenu. # # Arguments: # menu - The menu window. # rootx, rooty - Root coordinates of mouse. # state - Modifier state. proc tkMenuLeave {menu rootx rooty state} { global tkPriv set tkPriv(window) {} if {[string equal [$menu index active] "none"]} { return } if {[string equal [$menu type active] "cascade"] && [string equal [winfo containing $rootx $rooty] \ [$menu entrycget active -menu]]} { return } $menu activate none tkGenerateMenuSelect $menu } # tkMenuInvoke -- # This procedure is invoked when button 1 is released over a menu. # It invokes the appropriate menu action and unposts the menu if # it came from a menubutton. # # Arguments: # w - Name of the menu widget. # buttonRelease - 1 means this procedure is called because of # a button release; 0 means because of keystroke. proc tkMenuInvoke {w buttonRelease} { global tkPriv if {$buttonRelease && [string equal $tkPriv(window) {}]} { # Mouse was pressed over a menu without a menu button, then # dragged off the menu (possibly with a cascade posted) and # released. Unpost everything and quit. $w postcascade none $w activate none event generate $w <> tkMenuUnpost $w return } if {[string equal [$w type active] "cascade"]} { $w postcascade active set menu [$w entrycget active -menu] tkMenuFirstEntry $menu } elseif {[string equal [$w type active] "tearoff"]} { tkTearOffMenu $w tkMenuUnpost $w } elseif {[string equal [$w cget -type] "menubar"]} { $w postcascade none set active [$w index active] set isCascade [string equal [$w type $active] "cascade"] # Only de-activate the active item if it's a cascade; this prevents # the annoying "activation flicker" you otherwise get with # checkbuttons/commands/etc. on menubars if { $isCascade } { $w activate none event generate $w <> } tkMenuUnpost $w # If the active item is not a cascade, invoke it. This enables # the use of checkbuttons/commands/etc. on menubars (which is legal, # but not recommended) if { !$isCascade } { uplevel #0 [list $w invoke $active] } } else { tkMenuUnpost $w uplevel #0 [list $w invoke active] } } # tkMenuEscape -- # This procedure is invoked for the Cancel (or Escape) key. It unposts # the given menu and, if it is the top-level menu for a menu button, # unposts the menu button as well. # # Arguments: # menu - Name of the menu window. proc tkMenuEscape menu { set parent [winfo parent $menu] if {[string compare [winfo class $parent] "Menu"]} { tkMenuUnpost $menu } elseif {[string equal [$parent cget -type] "menubar"]} { tkMenuUnpost $menu tkRestoreOldGrab } else { tkMenuNextMenu $menu left } } # The following routines handle arrow keys. Arrow keys behave # differently depending on whether the menu is a menu bar or not. proc tkMenuUpArrow {menu} { if {[string equal [$menu cget -type] "menubar"]} { tkMenuNextMenu $menu left } else { tkMenuNextEntry $menu -1 } } proc tkMenuDownArrow {menu} { if {[string equal [$menu cget -type] "menubar"]} { tkMenuNextMenu $menu right } else { tkMenuNextEntry $menu 1 } } proc tkMenuLeftArrow {menu} { if {[string equal [$menu cget -type] "menubar"]} { tkMenuNextEntry $menu -1 } else { tkMenuNextMenu $menu left } } proc tkMenuRightArrow {menu} { if {[string equal [$menu cget -type] "menubar"]} { tkMenuNextEntry $menu 1 } else { tkMenuNextMenu $menu right } } # tkMenuNextMenu -- # This procedure is invoked to handle "left" and "right" traversal # motions in menus. It traverses to the next menu in a menu bar, # or into or out of a cascaded menu. # # Arguments: # menu - The menu that received the keyboard # event. # direction - Direction in which to move: "left" or "right" proc tkMenuNextMenu {menu direction} { global tkPriv # First handle traversals into and out of cascaded menus. if {[string equal $direction "right"]} { set count 1 set parent [winfo parent $menu] set class [winfo class $parent] if {[string equal [$menu type active] "cascade"]} { $menu postcascade active set m2 [$menu entrycget active -menu] if {[string compare $m2 ""]} { tkMenuFirstEntry $m2 } return } else { set parent [winfo parent $menu] while {[string compare $parent "."]} { if {[string equal [winfo class $parent] "Menu"] \ && [string equal [$parent cget -type] "menubar"]} { tk_menuSetFocus $parent tkMenuNextEntry $parent 1 return } set parent [winfo parent $parent] } } } else { set count -1 set m2 [winfo parent $menu] if {[string equal [winfo class $m2] "Menu"]} { if {[string compare [$m2 cget -type] "menubar"]} { $menu activate none tkGenerateMenuSelect $menu tk_menuSetFocus $m2 # This code unposts any posted submenu in the parent. set tmp [$m2 index active] $m2 activate none $m2 activate $tmp return } } } # Can't traverse into or out of a cascaded menu. Go to the next # or previous menubutton, if that makes sense. set m2 [winfo parent $menu] if {[string equal [winfo class $m2] "Menu"]} { if {[string equal [$m2 cget -type] "menubar"]} { tk_menuSetFocus $m2 tkMenuNextEntry $m2 -1 return } } set w $tkPriv(postedMb) if {[string equal $w ""]} { return } set buttons [winfo children [winfo parent $w]] set length [llength $buttons] set i [expr {[lsearch -exact $buttons $w] + $count}] while {1} { while {$i < 0} { incr i $length } while {$i >= $length} { incr i -$length } set mb [lindex $buttons $i] if {[string equal [winfo class $mb] "Menubutton"] \ && [string compare [$mb cget -state] "disabled"] \ && [string compare [$mb cget -menu] ""] \ && [string compare [[$mb cget -menu] index last] "none"]} { break } if {[string equal $mb $w]} { return } incr i $count } tkMbPost $mb tkMenuFirstEntry [$mb cget -menu] } # tkMenuNextEntry -- # Activate the next higher or lower entry in the posted menu, # wrapping around at the ends. Disabled entries are skipped. # # Arguments: # menu - Menu window that received the keystroke. # count - 1 means go to the next lower entry, # -1 means go to the next higher entry. proc tkMenuNextEntry {menu count} { global tkPriv if {[string equal [$menu index last] "none"]} { return } set length [expr {[$menu index last]+1}] set quitAfter $length set active [$menu index active] if {[string equal $active "none"]} { set i 0 } else { set i [expr {$active + $count}] } while {1} { if {$quitAfter <= 0} { # We've tried every entry in the menu. Either there are # none, or they're all disabled. Just give up. return } while {$i < 0} { incr i $length } while {$i >= $length} { incr i -$length } if {[catch {$menu entrycget $i -state} state] == 0} { if {[string compare $state "disabled"]} { break } } if {$i == $active} { return } incr i $count incr quitAfter -1 } $menu activate $i tkGenerateMenuSelect $menu if {[string equal [$menu type $i] "cascade"]} { set cascade [$menu entrycget $i -menu] if {[string compare $cascade ""]} { # Here we auto-post a cascade. This is necessary when # we traverse left/right in the menubar, but undesirable when # we traverse up/down in a menu. $menu postcascade $i tkMenuFirstEntry $cascade } } } # tkMenuFind -- # This procedure searches the entire window hierarchy under w for # a menubutton that isn't disabled and whose underlined character # is "char" or an entry in a menubar that isn't disabled and whose # underlined character is "char". # It returns the name of that window, if found, or an # empty string if no matching window was found. If "char" is an # empty string then the procedure returns the name of the first # menubutton found that isn't disabled. # # Arguments: # w - Name of window where key was typed. # char - Underlined character to search for; # may be either upper or lower case, and # will match either upper or lower case. proc tkMenuFind {w char} { global tkPriv set char [string tolower $char] set windowlist [winfo child $w] foreach child $windowlist { # Don't descend into other toplevels. if {[string compare [winfo toplevel [focus]] \ [winfo toplevel $child]]} { continue } if {[string equal [winfo class $child] "Menu"] && \ [string equal [$child cget -type] "menubar"]} { if {[string equal $char ""]} { return $child } set last [$child index last] for {set i [$child cget -tearoff]} {$i <= $last} {incr i} { if {[string equal [$child type $i] "separator"]} { continue } set char2 [string index [$child entrycget $i -label] \ [$child entrycget $i -underline]] if {[string equal $char [string tolower $char2]] \ || [string equal $char ""]} { if {[string compare [$child entrycget $i -state] "disabled"]} { return $child } } } } } foreach child $windowlist { # Don't descend into other toplevels. if {[string compare [winfo toplevel [focus]] \ [winfo toplevel $child]]} { continue } switch [winfo class $child] { Menubutton { set char2 [string index [$child cget -text] \ [$child cget -underline]] if {[string equal $char [string tolower $char2]] \ || [string equal $char ""]} { if {[string compare [$child cget -state] "disabled"]} { return $child } } } default { set match [tkMenuFind $child $char] if {[string compare $match ""]} { return $match } } } } return {} } # tkTraverseToMenu -- # This procedure implements keyboard traversal of menus. Given an # ASCII character "char", it looks for a menubutton with that character # underlined. If one is found, it posts the menubutton's menu # # Arguments: # w - Window in which the key was typed (selects # a toplevel window). # char - Character that selects a menu. The case # is ignored. If an empty string, nothing # happens. proc tkTraverseToMenu {w char} { global tkPriv if {[string equal $char ""]} { return } while {[string equal [winfo class $w] "Menu"]} { if {[string compare [$w cget -type] "menubar"] \ && [string equal $tkPriv(postedMb) ""]} { return } if {[string equal [$w cget -type] "menubar"]} { break } set w [winfo parent $w] } set w [tkMenuFind [winfo toplevel $w] $char] if {[string compare $w ""]} { if {[string equal [winfo class $w] "Menu"]} { tk_menuSetFocus $w set tkPriv(window) $w tkSaveGrabInfo $w grab -global $w tkTraverseWithinMenu $w $char } else { tkMbPost $w tkMenuFirstEntry [$w cget -menu] } } } # tkFirstMenu -- # This procedure traverses to the first menubutton in the toplevel # for a given window, and posts that menubutton's menu. # # Arguments: # w - Name of a window. Selects which toplevel # to search for menubuttons. proc tkFirstMenu w { set w [tkMenuFind [winfo toplevel $w] ""] if {[string compare $w ""]} { if {[string equal [winfo class $w] "Menu"]} { tk_menuSetFocus $w set tkPriv(window) $w tkSaveGrabInfo $w grab -global $w tkMenuFirstEntry $w } else { tkMbPost $w tkMenuFirstEntry [$w cget -menu] } } } # tkTraverseWithinMenu # This procedure implements keyboard traversal within a menu. It # searches for an entry in the menu that has "char" underlined. If # such an entry is found, it is invoked and the menu is unposted. # # Arguments: # w - The name of the menu widget. # char - The character to look for; case is # ignored. If the string is empty then # nothing happens. proc tkTraverseWithinMenu {w char} { if {[string equal $char ""]} { return } set char [string tolower $char] set last [$w index last] if {[string equal $last "none"]} { return } for {set i 0} {$i <= $last} {incr i} { if {[catch {set char2 [string index \ [$w entrycget $i -label] [$w entrycget $i -underline]]}]} { continue } if {[string equal $char [string tolower $char2]]} { if {[string equal [$w type $i] "cascade"]} { $w activate $i $w postcascade active event generate $w <> set m2 [$w entrycget $i -menu] if {[string compare $m2 ""]} { tkMenuFirstEntry $m2 } } else { tkMenuUnpost $w uplevel #0 [list $w invoke $i] } return } } } # tkMenuFirstEntry -- # Given a menu, this procedure finds the first entry that isn't # disabled or a tear-off or separator, and activates that entry. # However, if there is already an active entry in the menu (e.g., # because of a previous call to tkPostOverPoint) then the active # entry isn't changed. This procedure also sets the input focus # to the menu. # # Arguments: # menu - Name of the menu window (possibly empty). proc tkMenuFirstEntry menu { if {[string equal $menu ""]} { return } tk_menuSetFocus $menu if {[string compare [$menu index active] "none"]} { return } set last [$menu index last] if {[string equal $last "none"]} { return } for {set i 0} {$i <= $last} {incr i} { if {([catch {set state [$menu entrycget $i -state]}] == 0) \ && [string compare $state "disabled"] \ && [string compare [$menu type $i] "tearoff"]} { $menu activate $i tkGenerateMenuSelect $menu # Only post the cascade if the current menu is a menubar; # otherwise, if the first entry of the cascade is a cascade, # we can get an annoying cascading effect resulting in a bunch of # menus getting posted (bug 676) if {[string equal [$menu type $i] "cascade"] && \ [string equal [$menu cget -type] "menubar"]} { set cascade [$menu entrycget $i -menu] if {[string compare $cascade ""]} { $menu postcascade $i tkMenuFirstEntry $cascade } } return } } } # tkMenuFindName -- # Given a menu and a text string, return the index of the menu entry # that displays the string as its label. If there is no such entry, # return an empty string. This procedure is tricky because some names # like "active" have a special meaning in menu commands, so we can't # always use the "index" widget command. # # Arguments: # menu - Name of the menu widget. # s - String to look for. proc tkMenuFindName {menu s} { set i "" if {![regexp {^active$|^last$|^none$|^[0-9]|^@} $s]} { catch {set i [$menu index $s]} return $i } set last [$menu index last] if {[string equal $last "none"]} { return } for {set i 0} {$i <= $last} {incr i} { if {![catch {$menu entrycget $i -label} label]} { if {[string equal $label $s]} { return $i } } } return "" } # tkPostOverPoint -- # This procedure posts a given menu such that a given entry in the # menu is centered over a given point in the root window. It also # activates the given entry. # # Arguments: # menu - Menu to post. # x, y - Root coordinates of point. # entry - Index of entry within menu to center over (x,y). # If omitted or specified as {}, then the menu's # upper-left corner goes at (x,y). proc tkPostOverPoint {menu x y {entry {}}} { global tcl_platform if {[string compare $entry {}]} { if {$entry == [$menu index last]} { incr y [expr {-([$menu yposition $entry] \ + [winfo reqheight $menu])/2}] } else { incr y [expr {-([$menu yposition $entry] \ + [$menu yposition [expr {$entry+1}]])/2}] } incr x [expr {-[winfo reqwidth $menu]/2}] } $menu post $x $y if {[string compare $entry {}] \ && [string compare [$menu entrycget $entry -state] "disabled"]} { $menu activate $entry tkGenerateMenuSelect $menu } } # tkSaveGrabInfo -- # Sets the variables tkPriv(oldGrab) and tkPriv(grabStatus) to record # the state of any existing grab on the w's display. # # Arguments: # w - Name of a window; used to select the display # whose grab information is to be recorded. proc tkSaveGrabInfo w { global tkPriv set tkPriv(oldGrab) [grab current $w] if {[string compare $tkPriv(oldGrab) ""]} { set tkPriv(grabStatus) [grab status $tkPriv(oldGrab)] } } # tkRestoreOldGrab -- # Restores the grab to what it was before TkSaveGrabInfo was called. # proc tkRestoreOldGrab {} { global tkPriv if {[string compare $tkPriv(oldGrab) ""]} { # Be careful restoring the old grab, since it's window may not # be visible anymore. catch { if {[string equal $tkPriv(grabStatus) "global"]} { grab set -global $tkPriv(oldGrab) } else { grab set $tkPriv(oldGrab) } } set tkPriv(oldGrab) "" } } proc tk_menuSetFocus {menu} { global tkPriv if {![info exists tkPriv(focus)] || [string equal $tkPriv(focus) {}]} { set tkPriv(focus) [focus] } focus $menu } proc tkGenerateMenuSelect {menu} { global tkPriv if {[string equal $tkPriv(activeMenu) $menu] \ && [string equal $tkPriv(activeItem) [$menu index active]]} { return } set tkPriv(activeMenu) $menu set tkPriv(activeItem) [$menu index active] event generate $menu <> } # tk_popup -- # This procedure pops up a menu and sets things up for traversing # the menu and its submenus. # # Arguments: # menu - Name of the menu to be popped up. # x, y - Root coordinates at which to pop up the # menu. # entry - Index of a menu entry to center over (x,y). # If omitted or specified as {}, then menu's # upper-left corner goes at (x,y). proc tk_popup {menu x y {entry {}}} { global tkPriv global tcl_platform if {[string compare $tkPriv(popup) ""] \ || [string compare $tkPriv(postedMb) ""]} { tkMenuUnpost {} } tkPostOverPoint $menu $x $y $entry if {[string equal $tcl_platform(platform) "unix"] \ && [winfo viewable $menu]} { tkSaveGrabInfo $menu grab -global $menu set tkPriv(popup) $menu tk_menuSetFocus $menu } } {# optMenu.tcl -- # # This file defines the procedure tk_optionMenu, which creates # an option button and its associated menu. # # RCS: @(#) $Id: optMenu.tcl,v 1.3 1998/09/14 18:23:24 stanton Exp $ # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # tk_optionMenu -- # This procedure creates an option button named $w and an associated # menu. Together they provide the functionality of Motif option menus: # they can be used to select one of many values, and the current value # appears in the global variable varName, as well as in the text of # the option menubutton. The name of the menu is returned as the # procedure's result, so that the caller can use it to change configuration # options on the menu or otherwise manipulate it. # # Arguments: # w - The name to use for the menubutton. # varName - Global variable to hold the currently selected value. # firstValue - First of legal values for option (must be >= 1). # args - Any number of additional values. proc tk_optionMenu {w varName firstValue args} { upvar #0 $varName var if {![info exists var]} { set var $firstValue } menubutton $w -textvariable $varName -indicatoron 1 -menu $w.menu \ -relief raised -bd 2 -highlightthickness 2 -anchor c \ -direction flush menu $w.menu -tearoff 0 $w.menu add radiobutton -label $firstValue -variable $varName foreach i $args { $w.menu add radiobutton -label $i -variable $varName } return $w.menu } # palette.tcl -- # # This file contains procedures that change the color palette used # by Tk. # # RCS: @(#) $Id: palette.tcl,v 1.5 1999/09/02 17:02:53 hobbs Exp $ # # Copyright (c) 1995-1997 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # tk_setPalette -- # Changes the default color scheme for a Tk application by setting # default colors in the option database and by modifying all of the # color options for existing widgets that have the default value. # # Arguments: # The arguments consist of either a single color name, which # will be used as the new background color (all other colors will # be computed from this) or an even number of values consisting of # option names and values. The name for an option is the one used # for the option database, such as activeForeground, not -activeforeground. proc tk_setPalette {args} { if {[winfo depth .] == 1} { # Just return on monochrome displays, otherwise errors will occur return } global tkPalette # Create an array that has the complete new palette. If some colors # aren't specified, compute them from other colors that are specified. if {[llength $args] == 1} { set new(background) [lindex $args 0] } else { array set new $args } if {![info exists new(background)]} { error "must specify a background color" } if {![info exists new(foreground)]} { set new(foreground) black } set bg [winfo rgb . $new(background)] set fg [winfo rgb . $new(foreground)] set darkerBg [format #%02x%02x%02x [expr {(9*[lindex $bg 0])/2560}] \ [expr {(9*[lindex $bg 1])/2560}] [expr {(9*[lindex $bg 2])/2560}]] foreach i {activeForeground insertBackground selectForeground \ highlightColor} { if {![info exists new($i)]} { set new($i) $new(foreground) } } if {![info exists new(disabledForeground)]} { set new(disabledForeground) [format #%02x%02x%02x \ [expr {(3*[lindex $bg 0] + [lindex $fg 0])/1024}] \ [expr {(3*[lindex $bg 1] + [lindex $fg 1])/1024}] \ [expr {(3*[lindex $bg 2] + [lindex $fg 2])/1024}]] } if {![info exists new(highlightBackground)]} { set new(highlightBackground) $new(background) } if {![info exists new(activeBackground)]} { # Pick a default active background that islighter than the # normal background. To do this, round each color component # up by 15% or 1/3 of the way to full white, whichever is # greater. foreach i {0 1 2} { set light($i) [expr {[lindex $bg $i]/256}] set inc1 [expr {($light($i)*15)/100}] set inc2 [expr {(255-$light($i))/3}] if {$inc1 > $inc2} { incr light($i) $inc1 } else { incr light($i) $inc2 } if {$light($i) > 255} { set light($i) 255 } } set new(activeBackground) [format #%02x%02x%02x $light(0) \ $light(1) $light(2)] } if {![info exists new(selectBackground)]} { set new(selectBackground) $darkerBg } if {![info exists new(troughColor)]} { set new(troughColor) $darkerBg } if {![info exists new(selectColor)]} { set new(selectColor) #b03060 } # let's make one of each of the widgets so we know what the # defaults are currently for this platform. toplevel .___tk_set_palette wm withdraw .___tk_set_palette foreach q {button canvas checkbutton entry frame label listbox \ menubutton menu message radiobutton scale scrollbar text} { $q .___tk_set_palette.$q } # Walk the widget hierarchy, recoloring all existing windows. # The option database must be set according to what we do here, # but it breaks things if we set things in the database while # we are changing colors...so, tkRecolorTree now returns the # option database changes that need to be made, and they # need to be evalled here to take effect. # We have to walk the whole widget tree instead of just # relying on the widgets we've created above to do the work # because different extensions may provide other kinds # of widgets that we don't currently know about, so we'll # walk the whole hierarchy just in case. eval [tkRecolorTree . new] catch {destroy .___tk_set_palette} # Change the option database so that future windows will get the # same colors. foreach option [array names new] { option add *$option $new($option) widgetDefault } # Save the options in the global variable tkPalette, for use the # next time we change the options. array set tkPalette [array get new] } # tkRecolorTree -- # This procedure changes the colors in a window and all of its # descendants, according to information provided by the colors # argument. This looks at the defaults provided by the option # database, if it exists, and if not, then it looks at the default # value of the widget itself. # # Arguments: # w - The name of a window. This window and all its # descendants are recolored. # colors - The name of an array variable in the caller, # which contains color information. Each element # is named after a widget configuration option, and # each value is the value for that option. proc tkRecolorTree {w colors} { global tkPalette upvar $colors c set result {} foreach dbOption [array names c] { set option -[string tolower $dbOption] if {![catch {$w config $option} value]} { # if the option database has a preference for this # dbOption, then use it, otherwise use the defaults # for the widget. set defaultcolor [option get $w $dbOption widgetDefault] if {[string match {} $defaultcolor]} { set defaultcolor [winfo rgb . [lindex $value 3]] } else { set defaultcolor [winfo rgb . $defaultcolor] } set chosencolor [winfo rgb . [lindex $value 4]] if {[string match $defaultcolor $chosencolor]} { # Change the option database so that future windows will get # the same colors. append result ";\noption add [list \ *[winfo class $w].$dbOption $c($dbOption) 60]" $w configure $option $c($dbOption) } } } foreach child [winfo children $w] { append result ";\n[tkRecolorTree $child c]" } return $result } # tkDarken -- # Given a color name, computes a new color value that darkens (or # brightens) the given color by a given percent. # # Arguments: # color - Name of starting color. # perecent - Integer telling how much to brighten or darken as a # percent: 50 means darken by 50%, 110 means brighten # by 10%. proc tkDarken {color percent} { foreach {red green blue} [winfo rgb . $color] { set red [expr {($red/256)*$percent/100}] set green [expr {($green/256)*$percent/100}] set blue [expr {($blue/256)*$percent/100}] break } if {$red > 255} { set red 255 } if {$green > 255} { set green 255 } if {$blue > 255} { set blue 255 } return [format "#%02x%02x%02x" $red $green $blue] } # tk_bisque -- # Reset the Tk color palette to the old "bisque" colors. # # Arguments: # None. proc tk_bisque {} { tk_setPalette activeBackground #e6ceb1 activeForeground black \ background #ffe4c4 disabledForeground #b0b0b0 foreground black \ highlightBackground #ffe4c4 highlightColor black \ insertBackground black selectColor #b03060 \ selectBackground #e6ceb1 selectForeground black \ troughColor #cdb79e } k# scale.tcl -- # # This file defines the default bindings for Tk scale widgets and provides # procedures that help in implementing the bindings. # # RCS: @(#) $Id: scale.tcl,v 1.7 2000/04/14 08:33:31 hobbs Exp $ # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994-1995 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # #------------------------------------------------------------------------- # The code below creates the default class bindings for entries. #------------------------------------------------------------------------- # Standard Motif bindings: bind Scale { if {$tk_strictMotif} { set tkPriv(activeBg) [%W cget -activebackground] %W config -activebackground [%W cget -background] } tkScaleActivate %W %x %y } bind Scale { tkScaleActivate %W %x %y } bind Scale { if {$tk_strictMotif} { %W config -activebackground $tkPriv(activeBg) } if {[string equal [%W cget -state] "active"]} { %W configure -state normal } } bind Scale <1> { tkScaleButtonDown %W %x %y } bind Scale { tkScaleDrag %W %x %y } bind Scale { } bind Scale { } bind Scale { tkCancelRepeat tkScaleEndDrag %W tkScaleActivate %W %x %y } bind Scale <2> { tkScaleButton2Down %W %x %y } bind Scale { tkScaleDrag %W %x %y } bind Scale { } bind Scale { } bind Scale { tkCancelRepeat tkScaleEndDrag %W tkScaleActivate %W %x %y } bind Scale { tkScaleControlPress %W %x %y } bind Scale { tkScaleIncrement %W up little noRepeat } bind Scale { tkScaleIncrement %W down little noRepeat } bind Scale { tkScaleIncrement %W up little noRepeat } bind Scale { tkScaleIncrement %W down little noRepeat } bind Scale { tkScaleIncrement %W up big noRepeat } bind Scale { tkScaleIncrement %W down big noRepeat } bind Scale { tkScaleIncrement %W up big noRepeat } bind Scale { tkScaleIncrement %W down big noRepeat } bind Scale { %W set [%W cget -from] } bind Scale { %W set [%W cget -to] } # tkScaleActivate -- # This procedure is invoked to check a given x-y position in the # scale and activate the slider if the x-y position falls within # the slider. # # Arguments: # w - The scale widget. # x, y - Mouse coordinates. proc tkScaleActivate {w x y} { if {[string equal [$w cget -state] "disabled"]} { return } if {[string equal [$w identify $x $y] "slider"]} { set state active } else { set state normal } if {[string compare [$w cget -state] $state]} { $w configure -state $state } } # tkScaleButtonDown -- # This procedure is invoked when a button is pressed in a scale. It # takes different actions depending on where the button was pressed. # # Arguments: # w - The scale widget. # x, y - Mouse coordinates of button press. proc tkScaleButtonDown {w x y} { global tkPriv set tkPriv(dragging) 0 set el [$w identify $x $y] if {[string equal $el "trough1"]} { tkScaleIncrement $w up little initial } elseif {[string equal $el "trough2"]} { tkScaleIncrement $w down little initial } elseif {[string equal $el "slider"]} { set tkPriv(dragging) 1 set tkPriv(initValue) [$w get] set coords [$w coords] set tkPriv(deltaX) [expr {$x - [lindex $coords 0]}] set tkPriv(deltaY) [expr {$y - [lindex $coords 1]}] $w configure -sliderrelief sunken } } # tkScaleDrag -- # This procedure is called when the mouse is dragged with # mouse button 1 down. If the drag started inside the slider # (i.e. the scale is active) then the scale's value is adjusted # to reflect the mouse's position. # # Arguments: # w - The scale widget. # x, y - Mouse coordinates. proc tkScaleDrag {w x y} { global tkPriv if {!$tkPriv(dragging)} { return } $w set [$w get [expr {$x-$tkPriv(deltaX)}] [expr {$y-$tkPriv(deltaY)}]] } # tkScaleEndDrag -- # This procedure is called to end an interactive drag of the # slider. It just marks the drag as over. # # Arguments: # w - The scale widget. proc tkScaleEndDrag {w} { global tkPriv set tkPriv(dragging) 0 $w configure -sliderrelief raised } # tkScaleIncrement -- # This procedure is invoked to increment the value of a scale and # to set up auto-repeating of the action if that is desired. The # way the value is incremented depends on the "dir" and "big" # arguments. # # Arguments: # w - The scale widget. # dir - "up" means move value towards -from, "down" means # move towards -to. # big - Size of increments: "big" or "little". # repeat - Whether and how to auto-repeat the action: "noRepeat" # means don't auto-repeat, "initial" means this is the # first action in an auto-repeat sequence, and "again" # means this is the second repetition or later. proc tkScaleIncrement {w dir big repeat} { global tkPriv if {![winfo exists $w]} return if {[string equal $big "big"]} { set inc [$w cget -bigincrement] if {$inc == 0} { set inc [expr {abs([$w cget -to] - [$w cget -from])/10.0}] } if {$inc < [$w cget -resolution]} { set inc [$w cget -resolution] } } else { set inc [$w cget -resolution] } if {([$w cget -from] > [$w cget -to]) ^ [string equal $dir "up"]} { set inc [expr {-$inc}] } $w set [expr {[$w get] + $inc}] if {[string equal $repeat "again"]} { set tkPriv(afterId) [after [$w cget -repeatinterval] \ [list tkScaleIncrement $w $dir $big again]] } elseif {[string equal $repeat "initial"]} { set delay [$w cget -repeatdelay] if {$delay > 0} { set tkPriv(afterId) [after $delay \ [list tkScaleIncrement $w $dir $big again]] } } } # tkScaleControlPress -- # This procedure handles button presses that are made with the Control # key down. Depending on the mouse position, it adjusts the scale # value to one end of the range or the other. # # Arguments: # w - The scale widget. # x, y - Mouse coordinates where the button was pressed. proc tkScaleControlPress {w x y} { set el [$w identify $x $y] if {[string equal $el "trough1"]} { $w set [$w cget -from] } elseif {[string equal $el "trough2"]} { $w set [$w cget -to] } } # tkScaleButton2Down # This procedure is invoked when button 2 is pressed over a scale. # It sets the value to correspond to the mouse position and starts # a slider drag. # # Arguments: # w - The scrollbar widget. # x, y - Mouse coordinates within the widget. proc tkScaleButton2Down {w x y} { global tkPriv if {[string equal [$w cget -state] "disabled"]} { return } $w configure -state active $w set [$w get $x $y] set tkPriv(dragging) 1 set tkPriv(initValue) [$w get] set coords "$x $y" set tkPriv(deltaX) 0 set tkPriv(deltaY) 0 } -# scrlbar.tcl -- # # This file defines the default bindings for Tk scrollbar widgets. # It also provides procedures that help in implementing the bindings. # # RCS: @(#) $Id: scrlbar.tcl,v 1.8 2000/01/06 02:22:24 hobbs Exp $ # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # #------------------------------------------------------------------------- # The code below creates the default class bindings for scrollbars. #------------------------------------------------------------------------- # Standard Motif bindings: if {[string compare $tcl_platform(platform) "windows"] && \ [string compare $tcl_platform(platform) "macintosh"]} { bind Scrollbar { if {$tk_strictMotif} { set tkPriv(activeBg) [%W cget -activebackground] %W config -activebackground [%W cget -background] } %W activate [%W identify %x %y] } bind Scrollbar { %W activate [%W identify %x %y] } # The "info exists" command in the following binding handles the # situation where a Leave event occurs for a scrollbar without the Enter # event. This seems to happen on some systems (such as Solaris 2.4) for # unknown reasons. bind Scrollbar { if {$tk_strictMotif && [info exists tkPriv(activeBg)]} { %W config -activebackground $tkPriv(activeBg) } %W activate {} } bind Scrollbar <1> { tkScrollButtonDown %W %x %y } bind Scrollbar { tkScrollDrag %W %x %y } bind Scrollbar { tkScrollDrag %W %x %y } bind Scrollbar { tkScrollButtonUp %W %x %y } bind Scrollbar { # Prevents binding from being invoked. } bind Scrollbar { # Prevents binding from being invoked. } bind Scrollbar <2> { tkScrollButton2Down %W %x %y } bind Scrollbar { # Do nothing, since button 1 is already down. } bind Scrollbar { # Do nothing, since button 2 is already down. } bind Scrollbar { tkScrollDrag %W %x %y } bind Scrollbar { tkScrollButtonUp %W %x %y } bind Scrollbar { # Do nothing: B1 release will handle it. } bind Scrollbar { # Do nothing: B2 release will handle it. } bind Scrollbar { # Prevents binding from being invoked. } bind Scrollbar { # Prevents binding from being invoked. } bind Scrollbar { tkScrollTopBottom %W %x %y } bind Scrollbar { tkScrollTopBottom %W %x %y } bind Scrollbar { tkScrollByUnits %W v -1 } bind Scrollbar { tkScrollByUnits %W v 1 } bind Scrollbar { tkScrollByPages %W v -1 } bind Scrollbar { tkScrollByPages %W v 1 } bind Scrollbar { tkScrollByUnits %W h -1 } bind Scrollbar { tkScrollByUnits %W h 1 } bind Scrollbar { tkScrollByPages %W h -1 } bind Scrollbar { tkScrollByPages %W h 1 } bind Scrollbar { tkScrollByPages %W hv -1 } bind Scrollbar { tkScrollByPages %W hv 1 } bind Scrollbar { tkScrollToPos %W 0 } bind Scrollbar { tkScrollToPos %W 1 } } # tkScrollButtonDown -- # This procedure is invoked when a button is pressed in a scrollbar. # It changes the way the scrollbar is displayed and takes actions # depending on where the mouse is. # # Arguments: # w - The scrollbar widget. # x, y - Mouse coordinates. proc tkScrollButtonDown {w x y} { global tkPriv set tkPriv(relief) [$w cget -activerelief] $w configure -activerelief sunken set element [$w identify $x $y] if {[string equal $element "slider"]} { tkScrollStartDrag $w $x $y } else { tkScrollSelect $w $element initial } } # tkScrollButtonUp -- # This procedure is invoked when a button is released in a scrollbar. # It cancels scans and auto-repeats that were in progress, and restores # the way the active element is displayed. # # Arguments: # w - The scrollbar widget. # x, y - Mouse coordinates. proc tkScrollButtonUp {w x y} { global tkPriv tkCancelRepeat if {[info exists tkPriv(relief)]} { # Avoid error due to spurious release events $w configure -activerelief $tkPriv(relief) tkScrollEndDrag $w $x $y $w activate [$w identify $x $y] } } # tkScrollSelect -- # This procedure is invoked when a button is pressed over the scrollbar. # It invokes one of several scrolling actions depending on where in # the scrollbar the button was pressed. # # Arguments: # w - The scrollbar widget. # element - The element of the scrollbar that was selected, such # as "arrow1" or "trough2". Shouldn't be "slider". # repeat - Whether and how to auto-repeat the action: "noRepeat" # means don't auto-repeat, "initial" means this is the # first action in an auto-repeat sequence, and "again" # means this is the second repetition or later. proc tkScrollSelect {w element repeat} { global tkPriv if {![winfo exists $w]} return switch -- $element { "arrow1" {tkScrollByUnits $w hv -1} "trough1" {tkScrollByPages $w hv -1} "trough2" {tkScrollByPages $w hv 1} "arrow2" {tkScrollByUnits $w hv 1} default {return} } if {[string equal $repeat "again"]} { set tkPriv(afterId) [after [$w cget -repeatinterval] \ [list tkScrollSelect $w $element again]] } elseif {[string equal $repeat "initial"]} { set delay [$w cget -repeatdelay] if {$delay > 0} { set tkPriv(afterId) [after $delay \ [list tkScrollSelect $w $element again]] } } } # tkScrollStartDrag -- # This procedure is called to initiate a drag of the slider. It just # remembers the starting position of the mouse and slider. # # Arguments: # w - The scrollbar widget. # x, y - The mouse position at the start of the drag operation. proc tkScrollStartDrag {w x y} { global tkPriv if {[string equal [$w cget -command] ""]} { return } set tkPriv(pressX) $x set tkPriv(pressY) $y set tkPriv(initValues) [$w get] set iv0 [lindex $tkPriv(initValues) 0] if {[llength $tkPriv(initValues)] == 2} { set tkPriv(initPos) $iv0 } elseif {$iv0 == 0} { set tkPriv(initPos) 0.0 } else { set tkPriv(initPos) [expr {(double([lindex $tkPriv(initValues) 2])) \ / [lindex $tkPriv(initValues) 0]}] } } # tkScrollDrag -- # This procedure is called for each mouse motion even when the slider # is being dragged. It notifies the associated widget if we're not # jump scrolling, and it just updates the scrollbar if we are jump # scrolling. # # Arguments: # w - The scrollbar widget. # x, y - The current mouse position. proc tkScrollDrag {w x y} { global tkPriv if {[string equal $tkPriv(initPos) ""]} { return } set delta [$w delta [expr {$x - $tkPriv(pressX)}] [expr {$y - $tkPriv(pressY)}]] if {[$w cget -jump]} { if {[llength $tkPriv(initValues)] == 2} { $w set [expr {[lindex $tkPriv(initValues) 0] + $delta}] \ [expr {[lindex $tkPriv(initValues) 1] + $delta}] } else { set delta [expr {round($delta * [lindex $tkPriv(initValues) 0])}] eval [list $w] set [lreplace $tkPriv(initValues) 2 3 \ [expr {[lindex $tkPriv(initValues) 2] + $delta}] \ [expr {[lindex $tkPriv(initValues) 3] + $delta}]] } } else { tkScrollToPos $w [expr {$tkPriv(initPos) + $delta}] } } # tkScrollEndDrag -- # This procedure is called to end an interactive drag of the slider. # It scrolls the window if we're in jump mode, otherwise it does nothing. # # Arguments: # w - The scrollbar widget. # x, y - The mouse position at the end of the drag operation. proc tkScrollEndDrag {w x y} { global tkPriv if {[string equal $tkPriv(initPos) ""]} { return } if {[$w cget -jump]} { set delta [$w delta [expr {$x - $tkPriv(pressX)}] \ [expr {$y - $tkPriv(pressY)}]] tkScrollToPos $w [expr {$tkPriv(initPos) + $delta}] } set tkPriv(initPos) "" } # tkScrollByUnits -- # This procedure tells the scrollbar's associated widget to scroll up # or down by a given number of units. It notifies the associated widget # in different ways for old and new command syntaxes. # # Arguments: # w - The scrollbar widget. # orient - Which kinds of scrollbars this applies to: "h" for # horizontal, "v" for vertical, "hv" for both. # amount - How many units to scroll: typically 1 or -1. proc tkScrollByUnits {w orient amount} { set cmd [$w cget -command] if {[string equal $cmd ""] || ([string first \ [string index [$w cget -orient] 0] $orient] < 0)} { return } set info [$w get] if {[llength $info] == 2} { uplevel #0 $cmd scroll $amount units } else { uplevel #0 $cmd [expr {[lindex $info 2] + $amount}] } } # tkScrollByPages -- # This procedure tells the scrollbar's associated widget to scroll up # or down by a given number of screenfuls. It notifies the associated # widget in different ways for old and new command syntaxes. # # Arguments: # w - The scrollbar widget. # orient - Which kinds of scrollbars this applies to: "h" for # horizontal, "v" for vertical, "hv" for both. # amount - How many screens to scroll: typically 1 or -1. proc tkScrollByPages {w orient amount} { set cmd [$w cget -command] if {[string equal $cmd ""] || ([string first \ [string index [$w cget -orient] 0] $orient] < 0)} { return } set info [$w get] if {[llength $info] == 2} { uplevel #0 $cmd scroll $amount pages } else { uplevel #0 $cmd [expr {[lindex $info 2] + $amount*([lindex $info 1] - 1)}] } } # tkScrollToPos -- # This procedure tells the scrollbar's associated widget to scroll to # a particular location, given by a fraction between 0 and 1. It notifies # the associated widget in different ways for old and new command syntaxes. # # Arguments: # w - The scrollbar widget. # pos - A fraction between 0 and 1 indicating a desired position # in the document. proc tkScrollToPos {w pos} { set cmd [$w cget -command] if {[string equal $cmd ""]} { return } set info [$w get] if {[llength $info] == 2} { uplevel #0 $cmd moveto $pos } else { uplevel #0 $cmd [expr {round([lindex $info 0]*$pos)}] } } # tkScrollTopBottom # Scroll to the top or bottom of the document, depending on the mouse # position. # # Arguments: # w - The scrollbar widget. # x, y - Mouse coordinates within the widget. proc tkScrollTopBottom {w x y} { global tkPriv set element [$w identify $x $y] if {[string match *1 $element]} { tkScrollToPos $w 0 } elseif {[string match *2 $element]} { tkScrollToPos $w 1 } # Set tkPriv(relief), since it's needed by tkScrollButtonUp. set tkPriv(relief) [$w cget -activerelief] } # tkScrollButton2Down # This procedure is invoked when button 2 is pressed over a scrollbar. # If the button is over the trough or slider, it sets the scrollbar to # the mouse position and starts a slider drag. Otherwise it just # behaves the same as button 1. # # Arguments: # w - The scrollbar widget. # x, y - Mouse coordinates within the widget. proc tkScrollButton2Down {w x y} { global tkPriv set element [$w identify $x $y] if {[string match {arrow[12]} $element]} { tkScrollButtonDown $w $x $y return } tkScrollToPos $w [$w fraction $x $y] set tkPriv(relief) [$w cget -activerelief] # Need the "update idletasks" below so that the widget calls us # back to reset the actual scrollbar position before we start the # slider drag. update idletasks $w configure -activerelief sunken $w activate slider tkScrollStartDrag $w $x $y } 1# tearoff.tcl -- # # This file contains procedures that implement tear-off menus. # # RCS: @(#) $Id: tearoff.tcl,v 1.6 2000/01/06 02:22:24 hobbs Exp $ # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # tkTearoffMenu -- # Given the name of a menu, this procedure creates a torn-off menu # that is identical to the given menu (including nested submenus). # The new torn-off menu exists as a toplevel window managed by the # window manager. The return value is the name of the new menu. # The window is created at the point specified by x and y # # Arguments: # w - The menu to be torn-off (duplicated). # x - x coordinate where window is created # y - y coordinate where window is created proc tkTearOffMenu {w {x 0} {y 0}} { # Find a unique name to use for the torn-off menu. Find the first # ancestor of w that is a toplevel but not a menu, and use this as # the parent of the new menu. This guarantees that the torn off # menu will be on the same screen as the original menu. By making # it a child of the ancestor, rather than a child of the menu, it # can continue to live even if the menu is deleted; it will go # away when the toplevel goes away. if {$x == 0} { set x [winfo rootx $w] } if {$y == 0} { set y [winfo rooty $w] } set parent [winfo parent $w] while {[string compare [winfo toplevel $parent] $parent] \ || [string equal [winfo class $parent] "Menu"]} { set parent [winfo parent $parent] } if {[string equal $parent "."]} { set parent "" } for {set i 1} 1 {incr i} { set menu $parent.tearoff$i if {![winfo exists $menu]} { break } } $w clone $menu tearoff # Pick a title for the new menu by looking at the parent of the # original: if the parent is a menu, then use the text of the active # entry. If it's a menubutton then use its text. set parent [winfo parent $w] if {[string compare [$menu cget -title] ""]} { wm title $menu [$menu cget -title] } else { switch [winfo class $parent] { Menubutton { wm title $menu [$parent cget -text] } Menu { wm title $menu [$parent entrycget active -label] } } } $menu post $x $y if {[winfo exists $menu] == 0} { return "" } # Set tkPriv(focus) on entry: otherwise the focus will get lost # after keyboard invocation of a sub-menu (it will stay on the # submenu). bind $menu { set tkPriv(focus) %W } # If there is a -tearoffcommand option for the menu, invoke it # now. set cmd [$w cget -tearoffcommand] if {[string compare $cmd ""]} { uplevel #0 $cmd [list $w $menu] } return $menu } # tkMenuDup -- # Given a menu (hierarchy), create a duplicate menu (hierarchy) # in a given window. # # Arguments: # src - Source window. Must be a menu. It and its # menu descendants will be duplicated at dst. # dst - Name to use for topmost menu in duplicate # hierarchy. proc tkMenuDup {src dst type} { set cmd [list menu $dst -type $type] foreach option [$src configure] { if {[llength $option] == 2} { continue } if {[string equal [lindex $option 0] "-type"]} { continue } lappend cmd [lindex $option 0] [lindex $option 4] } eval $cmd set last [$src index last] if {[string equal $last "none"]} { return } for {set i [$src cget -tearoff]} {$i <= $last} {incr i} { set cmd [list $dst add [$src type $i]] foreach option [$src entryconfigure $i] { lappend cmd [lindex $option 0] [lindex $option 4] } eval $cmd } # Duplicate the binding tags and bindings from the source menu. set tags [bindtags $src] set srcLen [string length $src] # Copy tags to x, replacing each substring of src with dst. while {[set index [string first $src $tags]] != -1} { append x [string range $tags 0 [expr {$index - 1}]]$dst set tags [string range $tags [expr {$index + $srcLen}] end] } append x $tags bindtags $dst $x foreach event [bind $src] { unset x set script [bind $src $event] set eventLen [string length $event] # Copy script to x, replacing each substring of event with dst. while {[set index [string first $event $script]] != -1} { append x [string range $script 0 [expr {$index - 1}]] append x $dst set script [string range $script [expr {$index + $eventLen}] end] } append x $script bind $dst $event $x } } n# text.tcl -- # # This file defines the default bindings for Tk text widgets and provides # procedures that help in implementing the bindings. # # RCS: @(#) $Id: text.tcl,v 1.12.2.1 2001/04/04 07:57:17 hobbs Exp $ # # Copyright (c) 1992-1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. # Copyright (c) 1998 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # #------------------------------------------------------------------------- # Elements of tkPriv that are used in this file: # # afterId - If non-null, it means that auto-scanning is underway # and it gives the "after" id for the next auto-scan # command to be executed. # char - Character position on the line; kept in order # to allow moving up or down past short lines while # still remembering the desired position. # mouseMoved - Non-zero means the mouse has moved a significant # amount since the button went down (so, for example, # start dragging out a selection). # prevPos - Used when moving up or down lines via the keyboard. # Keeps track of the previous insert position, so # we can distinguish a series of ups and downs, all # in a row, from a new up or down. # selectMode - The style of selection currently underway: # char, word, or line. # x, y - Last known mouse coordinates for scanning # and auto-scanning. #------------------------------------------------------------------------- #------------------------------------------------------------------------- # The code below creates the default class bindings for text widgets. #------------------------------------------------------------------------- # Standard Motif bindings: bind Text <1> { tkTextButton1 %W %x %y %W tag remove sel 0.0 end } bind Text { set tkPriv(x) %x set tkPriv(y) %y tkTextSelectTo %W %x %y } bind Text { set tkPriv(selectMode) word tkTextSelectTo %W %x %y catch {%W mark set insert sel.last} catch {%W mark set anchor sel.first} } bind Text { set tkPriv(selectMode) line tkTextSelectTo %W %x %y catch {%W mark set insert sel.last} catch {%W mark set anchor sel.first} } bind Text { tkTextResetAnchor %W @%x,%y set tkPriv(selectMode) char tkTextSelectTo %W %x %y } bind Text { set tkPriv(selectMode) word tkTextSelectTo %W %x %y 1 } bind Text { set tkPriv(selectMode) line tkTextSelectTo %W %x %y } bind Text { set tkPriv(x) %x set tkPriv(y) %y tkTextAutoScan %W } bind Text { tkCancelRepeat } bind Text { tkCancelRepeat } bind Text { %W mark set insert @%x,%y } bind Text { tkTextSetCursor %W insert-1c } bind Text { tkTextSetCursor %W insert+1c } bind Text { tkTextSetCursor %W [tkTextUpDownLine %W -1] } bind Text { tkTextSetCursor %W [tkTextUpDownLine %W 1] } bind Text { tkTextKeySelect %W [%W index {insert - 1c}] } bind Text { tkTextKeySelect %W [%W index {insert + 1c}] } bind Text { tkTextKeySelect %W [tkTextUpDownLine %W -1] } bind Text { tkTextKeySelect %W [tkTextUpDownLine %W 1] } bind Text { tkTextSetCursor %W [tkTextPrevPos %W insert tcl_startOfPreviousWord] } bind Text { tkTextSetCursor %W [tkTextNextWord %W insert] } bind Text { tkTextSetCursor %W [tkTextPrevPara %W insert] } bind Text { tkTextSetCursor %W [tkTextNextPara %W insert] } bind Text { tkTextKeySelect %W [tkTextPrevPos %W insert tcl_startOfPreviousWord] } bind Text { tkTextKeySelect %W [tkTextNextWord %W insert] } bind Text { tkTextKeySelect %W [tkTextPrevPara %W insert] } bind Text { tkTextKeySelect %W [tkTextNextPara %W insert] } bind Text { tkTextSetCursor %W [tkTextScrollPages %W -1] } bind Text { tkTextKeySelect %W [tkTextScrollPages %W -1] } bind Text { tkTextSetCursor %W [tkTextScrollPages %W 1] } bind Text { tkTextKeySelect %W [tkTextScrollPages %W 1] } bind Text { %W xview scroll -1 page } bind Text { %W xview scroll 1 page } bind Text { tkTextSetCursor %W {insert linestart} } bind Text { tkTextKeySelect %W {insert linestart} } bind Text { tkTextSetCursor %W {insert lineend} } bind Text { tkTextKeySelect %W {insert lineend} } bind Text { tkTextSetCursor %W 1.0 } bind Text { tkTextKeySelect %W 1.0 } bind Text { tkTextSetCursor %W {end - 1 char} } bind Text { tkTextKeySelect %W {end - 1 char} } bind Text { if { [string equal [%W cget -state] "normal"] } { tkTextInsert %W \t focus %W break } } bind Text { # Needed only to keep binding from triggering; doesn't # have to actually do anything. break } bind Text { focus [tk_focusNext %W] } bind Text { focus [tk_focusPrev %W] } bind Text { tkTextInsert %W \t } bind Text { tkTextInsert %W \n } bind Text { if {[string compare [%W tag nextrange sel 1.0 end] ""]} { %W delete sel.first sel.last } else { %W delete insert %W see insert } } bind Text { if {[string compare [%W tag nextrange sel 1.0 end] ""]} { %W delete sel.first sel.last } elseif {[%W compare insert != 1.0]} { %W delete insert-1c %W see insert } } bind Text { %W mark set anchor insert } bind Text