tk8.6.8/0000755003604700454610000000000013217010003010454 5ustar dgp771divtk8.6.8/library/0000755003604700454610000000000013217010003012120 5ustar dgp771divtk8.6.8/library/megawidget.tcl0000644003604700454610000002254113212005724014756 0ustar dgp771div# megawidget.tcl # # Basic megawidget support classes. Experimental for any use other than # the ::tk::IconList megawdget, which is itself only designed for use in # the Unix file dialogs. # # Copyright (c) 2009-2010 Donal K. Fellows # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # package require Tk 8.6 ::oo::class create ::tk::Megawidget { superclass ::oo::class method unknown {w args} { if {[string match .* $w]} { [self] create $w {*}$args return $w } next $w {*}$args } unexport new unknown self method create {name superclasses body} { next $name [list \ superclass ::tk::MegawidgetClass {*}$superclasses]\;$body } } ::oo::class create ::tk::MegawidgetClass { variable w hull options IdleCallbacks constructor args { # Extract the "widget name" from the object name set w [namespace tail [self]] # Configure things tclParseConfigSpec [my varname options] [my GetSpecs] "" $args # Move the object out of the way of the hull widget rename [self] _tmp # Make the hull widget(s) my CreateHull bind $hull [list [namespace which my] destroy] # Rename things into their final places rename ::$w theWidget rename [self] ::$w # Make the contents my Create } destructor { foreach {name cb} [array get IdleCallbacks] { after cancel $cb unset IdleCallbacks($name) } if {[winfo exists $w]} { bind $hull {} destroy $w } } #################################################################### # # MegawidgetClass::configure -- # # Implementation of 'configure' for megawidgets. Emulates the operation # of the standard Tk configure method fairly closely, which makes things # substantially more complex than they otherwise would be. # # This method assumes that the 'GetSpecs' method returns a description # of all the specifications of the options (i.e., as Tk returns except # with the actual values removed). It also assumes that the 'options' # array in the class holds all options; it is up to subclasses to set # traces on that array if they want to respond to configuration changes. # # TODO: allow unambiguous abbreviations. # method configure args { # Configure behaves differently depending on the number of arguments set argc [llength $args] if {$argc == 0} { return [lmap spec [my GetSpecs] { lappend spec $options([lindex $spec 0]) }] } elseif {$argc == 1} { set opt [lindex $args 0] if {[info exists options($opt)]} { set spec [lsearch -inline -index 0 -exact [my GetSpecs] $opt] return [linsert $spec end $options($opt)] } } elseif {$argc == 2} { # Special case for where we're setting a single option. This # avoids some of the costly operations. We still do the [array # get] as this gives a sufficiently-consistent trace. set opt [lindex $args 0] if {[dict exists [array get options] $opt]} { # Actually set the new value of the option. Use a catch to # allow a megawidget user to throw an error from a write trace # on the options array to reject invalid values. try { array set options $args } on error {ret info} { # Rethrow the error to get a clean stack trace return -code error -errorcode [dict get $info -errorcode] $ret } return } } elseif {$argc % 2 == 0} { # Check that all specified options exist. Any unknown option will # cause the merged dictionary to be bigger than the options array set merge [dict merge [array get options] $args] if {[dict size $merge] == [array size options]} { # Actually set the new values of the options. Use a catch to # allow a megawidget user to throw an error from a write trace # on the options array to reject invalid values try { array set options $args } on error {ret info} { # Rethrow the error to get a clean stack trace return -code error -errorcode [dict get $info -errorcode] $ret } return } # Due to the order of the merge, the unknown options will be at # the end of the dict. This makes the first unknown option easy to # find. set opt [lindex [dict keys $merge] [array size options]] } else { set opt [lindex $args end] return -code error -errorcode [list TK VALUE_MISSING] \ "value for \"$opt\" missing" } return -code error -errorcode [list TK LOOKUP OPTION $opt] \ "bad option \"$opt\": must be [tclListValidFlags options]" } #################################################################### # # MegawidgetClass::cget -- # # Implementation of 'cget' for megawidgets. Emulates the operation of # the standard Tk cget method fairly closely. # # This method assumes that the 'options' array in the class holds all # options; it is up to subclasses to set traces on that array if they # want to respond to configuration reads. # # TODO: allow unambiguous abbreviations. # method cget option { return $options($option) } #################################################################### # # MegawidgetClass::TraceOption -- # # Sets up the tracing of an element of the options variable. # method TraceOption {option method args} { set callback [list my $method {*}$args] trace add variable options($option) write [namespace code $callback] } #################################################################### # # MegawidgetClass::GetSpecs -- # # Return a list of descriptions of options supported by this # megawidget. Each option is described by the 4-tuple list, consisting # of the name of the option, the "option database" name, the "option # database" class-name, and the default value of the option. These are # the same values returned by calling the configure method of a widget, # except without the current values of the options. # method GetSpecs {} { return { {-takefocus takeFocus TakeFocus {}} } } #################################################################### # # MegawidgetClass::CreateHull -- # # Creates the real main widget of the megawidget. This is often a frame # or toplevel widget, but isn't always (lightweight megawidgets might # use a content widget directly). # # The name of the hull widget is given by the 'w' instance variable. The # name should be written into the 'hull' instance variable. The command # created by this method will be renamed. # method CreateHull {} { return -code error -errorcode {TCL OO ABSTRACT_METHOD} \ "method must be overridden" } #################################################################### # # MegawidgetClass::Create -- # # Creates the content of the megawidget. The name of the widget to # create the content in will be in the 'hull' instance variable. # method Create {} { return -code error -errorcode {TCL OO ABSTRACT_METHOD} \ "method must be overridden" } #################################################################### # # MegawidgetClass::WhenIdle -- # # Arrange for a method to be called on the current instance when Tk is # idle. Only one such method call per method will be queued; subsequent # queuing actions before the callback fires will be silently ignored. # The additional args will be passed to the callback, and the callbacks # will be properly cancelled if the widget is destroyed. # method WhenIdle {method args} { if {![info exists IdleCallbacks($method)]} { set IdleCallbacks($method) [after idle [list \ [namespace which my] DoWhenIdle $method $args]] } } method DoWhenIdle {method arguments} { unset IdleCallbacks($method) tailcall my $method {*}$arguments } } #################################################################### # # tk::SimpleWidget -- # # Simple megawidget class that makes it easy create widgets that behave # like a ttk widget. It creates the hull as a ttk::frame and maps the # state manipulation methods of the overall megawidget to the equivalent # operations on the ttk::frame. # ::tk::Megawidget create ::tk::SimpleWidget {} { variable w hull options method GetSpecs {} { return { {-cursor cursor Cursor {}} {-takefocus takeFocus TakeFocus {}} } } method CreateHull {} { set hull [::ttk::frame $w -cursor $options(-cursor)] my TraceOption -cursor UpdateCursorOption } method UpdateCursorOption args { $hull configure -cursor $options(-cursor) } # Not fixed names, so can't forward method state args { tailcall $hull state {*}$args } method instate args { tailcall $hull instate {*}$args } } #################################################################### # # tk::FocusableWidget -- # # Simple megawidget class that makes a ttk-like widget that has a focus # ring. # ::tk::Megawidget create ::tk::FocusableWidget ::tk::SimpleWidget { variable w hull options method GetSpecs {} { return { {-cursor cursor Cursor {}} {-takefocus takeFocus TakeFocus ::ttk::takefocus} } } method CreateHull {} { ttk::frame $w set hull [ttk::entry $w.cHull -takefocus 0 -cursor $options(-cursor)] pack $hull -expand yes -fill both -ipadx 2 -ipady 2 my TraceOption -cursor UpdateCursorOption } } return # Local Variables: # mode: tcl # fill-column: 78 # End: tk8.6.8/library/palette.tcl0000644003604700454610000001736313212005724014305 0ustar dgp771div# palette.tcl -- # # This file contains procedures that change the color palette used # by Tk. # # 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 } # 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)]} { return -code error -errorcode {TK SET_PALETTE BACKGROUND} \ "must specify a background color" } set bg [winfo rgb . $new(background)] if {![info exists new(foreground)]} { # Note that the range of each value in the triple returned by # [winfo rgb] is 0-65535, and your eyes are more sensitive to # green than to red, and more to red than to blue. foreach {r g b} $bg {break} if {$r+1.5*$g+0.5*$b > 100000} { set new(foreground) black } else { set new(foreground) white } } lassign [winfo rgb . $new(foreground)] fg_r fg_g fg_b lassign $bg bg_r bg_g bg_b set darkerBg [format #%02x%02x%02x [expr {(9*$bg_r)/2560}] \ [expr {(9*$bg_g)/2560}] [expr {(9*$bg_b)/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*$bg_r + $fg_r)/1024}] \ [expr {(3*$bg_g + $fg_g)/1024}] \ [expr {(3*$bg_b + $fg_b)/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} color $bg { set light($i) [expr {$color/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 } # 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 labelframe listbox menubutton menu message radiobutton scale scrollbar spinbox 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, ::tk::RecolorTree 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 [tk::RecolorTree . new] 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 variable ::tk::Palette, for use the # next time we change the options. array set ::tk::Palette [array get new] } # ::tk::RecolorTree -- # 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 ::tk::RecolorTree {w colors} { upvar $colors c set result {} set prototype .___tk_set_palette.[string tolower [winfo class $w]] if {![winfo exists $prototype]} { unset prototype } foreach dbOption [array names c] { set option -[string tolower $dbOption] set class [string replace $dbOption 0 0 [string toupper \ [string index $dbOption 0]]] if {![catch {$w configure $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 $class] if {$defaultcolor eq "" || \ ([info exists prototype] && \ [$prototype cget $option] ne "$defaultcolor")} { set defaultcolor [lindex $value 3] } if {$defaultcolor ne ""} { set defaultcolor [winfo rgb . $defaultcolor] } set chosencolor [lindex $value 4] if {$chosencolor ne ""} { set chosencolor [winfo rgb . $chosencolor] } 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[::tk::RecolorTree $child c]" } return $result } # ::tk::Darken -- # 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 ::tk::Darken {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 \ selectBackground #e6ceb1 selectForeground black \ troughColor #cdb79e } tk8.6.8/library/unsupported.tcl0000644003604700454610000002401413212005724015226 0ustar dgp771div# unsupported.tcl -- # # Commands provided by Tk without official support. Use them at your # own risk. They may change or go away without notice. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # ---------------------------------------------------------------------- # Unsupported compatibility interface for folks accessing Tk's private # commands and variable against recommended usage. # ---------------------------------------------------------------------- namespace eval ::tk::unsupported { # Map from the old global names of Tk private commands to their # new namespace-encapsulated names. variable PrivateCommands array set PrivateCommands { tkButtonAutoInvoke ::tk::ButtonAutoInvoke tkButtonDown ::tk::ButtonDown tkButtonEnter ::tk::ButtonEnter tkButtonInvoke ::tk::ButtonInvoke tkButtonLeave ::tk::ButtonLeave tkButtonUp ::tk::ButtonUp tkCancelRepeat ::tk::CancelRepeat tkCheckRadioDown ::tk::CheckRadioDown tkCheckRadioEnter ::tk::CheckRadioEnter tkCheckRadioInvoke ::tk::CheckRadioInvoke tkColorDialog ::tk::dialog::color:: tkColorDialog_BuildDialog ::tk::dialog::color::BuildDialog tkColorDialog_CancelCmd ::tk::dialog::color::CancelCmd tkColorDialog_Config ::tk::dialog::color::Config tkColorDialog_CreateSelector ::tk::dialog::color::CreateSelector tkColorDialog_DrawColorScale ::tk::dialog::color::DrawColorScale tkColorDialog_EnterColorBar ::tk::dialog::color::EnterColorBar tkColorDialog_InitValues ::tk::dialog::color::InitValues tkColorDialog_HandleRGBEntry ::tk::dialog::color::HandleRGBEntry tkColorDialog_HandleSelEntry ::tk::dialog::color::HandleSelEntry tkColorDialog_LeaveColorBar ::tk::dialog::color::LeaveColorBar tkColorDialog_MoveSelector ::tk::dialog::color::MoveSelector tkColorDialog_OkCmd ::tk::dialog::color::OkCmd tkColorDialog_RedrawColorBars ::tk::dialog::color::RedrawColorBars tkColorDialog_RedrawFinalColor ::tk::dialog::color::RedrawFinalColor tkColorDialog_ReleaseMouse ::tk::dialog::color::ReleaseMouse tkColorDialog_ResizeColorBars ::tk::dialog::color::ResizeColorBars tkColorDialog_RgbToX ::tk::dialog::color::RgbToX tkColorDialog_SetRGBValue ::tk::dialog::color::SetRGBValue tkColorDialog_StartMove ::tk::dialog::color::StartMove tkColorDialog_XToRgb ::tk::dialog::color::XToRGB tkConsoleAbout ::tk::ConsoleAbout tkConsoleBind ::tk::ConsoleBind tkConsoleExit ::tk::ConsoleExit tkConsoleHistory ::tk::ConsoleHistory tkConsoleInit ::tk::ConsoleInit tkConsoleInsert ::tk::ConsoleInsert tkConsoleInvoke ::tk::ConsoleInvoke tkConsoleOutput ::tk::ConsoleOutput tkConsolePrompt ::tk::ConsolePrompt tkConsoleSource ::tk::ConsoleSource tkDarken ::tk::Darken tkEntryAutoScan ::tk::EntryAutoScan tkEntryBackspace ::tk::EntryBackspace tkEntryButton1 ::tk::EntryButton1 tkEntryClosestGap ::tk::EntryClosestGap tkEntryGetSelection ::tk::EntryGetSelection tkEntryInsert ::tk::EntryInsert tkEntryKeySelect ::tk::EntryKeySelect tkEntryMouseSelect ::tk::EntryMouseSelect tkEntryNextWord ::tk::EntryNextWord tkEntryPaste ::tk::EntryPaste tkEntryPreviousWord ::tk::EntryPreviousWord tkEntrySeeInsert ::tk::EntrySeeInsert tkEntrySetCursor ::tk::EntrySetCursor tkEntryTranspose ::tk::EntryTranspose tkEventMotifBindings ::tk::EventMotifBindings tkFDGetFileTypes ::tk::FDGetFileTypes tkFirstMenu ::tk::FirstMenu tkFocusGroup_BindIn ::tk::FocusGroup_BindIn tkFocusGroup_BindOut ::tk::FocusGroup_BindOut tkFocusGroup_Create ::tk::FocusGroup_Create tkFocusGroup_Destroy ::tk::FocusGroup_Destroy tkFocusGroup_In ::tk::FocusGroup_In tkFocusGroup_Out ::tk::FocusGroup_Out tkFocusOK ::tk::FocusOK tkGenerateMenuSelect ::tk::GenerateMenuSelect tkIconList ::tk::IconList tkListbox ::tk::Listbox tkListboxAutoScan ::tk::ListboxAutoScan tkListboxBeginExtend ::tk::ListboxBeginExtend tkListboxBeginSelect ::tk::ListboxBeginSelect tkListboxBeginToggle ::tk::ListboxBeginToggle tkListboxCancel ::tk::ListboxCancel tkListboxDataExtend ::tk::ListboxDataExtend tkListboxExtendUpDown ::tk::ListboxExtendUpDown tkListboxKeyAccel_Goto ::tk::ListboxKeyAccel_Goto tkListboxKeyAccel_Key ::tk::ListboxKeyAccel_Key tkListboxKeyAccel_Reset ::tk::ListboxKeyAccel_Reset tkListboxKeyAccel_Set ::tk::ListboxKeyAccel_Set tkListboxKeyAccel_Unset ::tk::ListboxKeyAccel_Unxet tkListboxMotion ::tk::ListboxMotion tkListboxSelectAll ::tk::ListboxSelectAll tkListboxUpDown ::tk::ListboxUpDown tkListboxBeginToggle ::tk::ListboxBeginToggle tkMbButtonUp ::tk::MbButtonUp tkMbEnter ::tk::MbEnter tkMbLeave ::tk::MbLeave tkMbMotion ::tk::MbMotion tkMbPost ::tk::MbPost tkMenuButtonDown ::tk::MenuButtonDown tkMenuDownArrow ::tk::MenuDownArrow tkMenuDup ::tk::MenuDup tkMenuEscape ::tk::MenuEscape tkMenuFind ::tk::MenuFind tkMenuFindName ::tk::MenuFindName tkMenuFirstEntry ::tk::MenuFirstEntry tkMenuInvoke ::tk::MenuInvoke tkMenuLeave ::tk::MenuLeave tkMenuLeftArrow ::tk::MenuLeftArrow tkMenuMotion ::tk::MenuMotion tkMenuNextEntry ::tk::MenuNextEntry tkMenuNextMenu ::tk::MenuNextMenu tkMenuRightArrow ::tk::MenuRightArrow tkMenuUnpost ::tk::MenuUnpost tkMenuUpArrow ::tk::MenuUpArrow tkMessageBox ::tk::MessageBox tkMotifFDialog ::tk::MotifFDialog tkMotifFDialog_ActivateDList ::tk::MotifFDialog_ActivateDList tkMotifFDialog_ActivateFList ::tk::MotifFDialog_ActivateFList tkMotifFDialog_ActivateFEnt ::tk::MotifFDialog_ActivateFEnt tkMotifFDialog_ActivateSEnt ::tk::MotifFDialog_ActivateSEnt tkMotifFDialog ::tk::MotifFDialog tkMotifFDialog_BrowseDList ::tk::MotifFDialog_BrowseDList tkMotifFDialog_BrowseFList ::tk::MotifFDialog_BrowseFList tkMotifFDialog_BuildUI ::tk::MotifFDialog_BuildUI tkMotifFDialog_CancelCmd ::tk::MotifFDialog_CancelCmd tkMotifFDialog_Config ::tk::MotifFDialog_Config tkMotifFDialog_Create ::tk::MotifFDialog_Create tkMotifFDialog_FileTypes ::tk::MotifFDialog_FileTypes tkMotifFDialog_FilterCmd ::tk::MotifFDialog_FilterCmd tkMotifFDialog_InterpFilter ::tk::MotifFDialog_InterpFilter tkMotifFDialog_LoadFiles ::tk::MotifFDialog_LoadFiles tkMotifFDialog_MakeSList ::tk::MotifFDialog_MakeSList tkMotifFDialog_OkCmd ::tk::MotifFDialog_OkCmd tkMotifFDialog_SetFilter ::tk::MotifFDialog_SetFilter tkMotifFDialog_SetListMode ::tk::MotifFDialog_SetListMode tkMotifFDialog_Update ::tk::MotifFDialog_Update tkPostOverPoint ::tk::PostOverPoint tkRecolorTree ::tk::RecolorTree tkRestoreOldGrab ::tk::RestoreOldGrab tkSaveGrabInfo ::tk::SaveGrabInfo tkScaleActivate ::tk::ScaleActivate tkScaleButtonDown ::tk::ScaleButtonDown tkScaleButton2Down ::tk::ScaleButton2Down tkScaleControlPress ::tk::ScaleControlPress tkScaleDrag ::tk::ScaleDrag tkScaleEndDrag ::tk::ScaleEndDrag tkScaleIncrement ::tk::ScaleIncrement tkScreenChanged ::tk::ScreenChanged tkScrollButtonDown ::tk::ScrollButtonDown tkScrollButton2Down ::tk::ScrollButton2Down tkScrollButtonDrag ::tk::ScrollButtonDrag tkScrollButtonUp ::tk::ScrollButtonUp tkScrollByPages ::tk::ScrollByPages tkScrollByUnits ::tk::ScrollByUnits tkScrollEndDrag ::tk::ScrollEndDrag tkScrollSelect ::tk::ScrollSelect tkScrollStartDrag ::tk::ScrollStartDrag tkScrollTopBottom ::tk::ScrollTopBottom tkScrollToPos ::tk::ScrollToPos tkTabToWindow ::tk::TabToWindow tkTearOffMenu ::tk::TearOffMenu tkTextAutoScan ::tk::TextAutoScan tkTextButton1 ::tk::TextButton1 tkTextClosestGap ::tk::TextClosestGap tkTextInsert ::tk::TextInsert tkTextKeyExtend ::tk::TextKeyExtend tkTextKeySelect ::tk::TextKeySelect tkTextNextPara ::tk::TextNextPara tkTextNextPos ::tk::TextNextPos tkTextNextWord ::tk::TextNextWord tkTextPaste ::tk::TextPaste tkTextPrevPara ::tk::TextPrevPara tkTextPrevPos ::tk::TextPrevPos tkTextPrevWord ::tk::TextPrevWord tkTextResetAnchor ::tk::TextResetAnchor tkTextScrollPages ::tk::TextScrollPages tkTextSelectTo ::tk::TextSelectTo tkTextSetCursor ::tk::TextSetCursor tkTextTranspose ::tk::TextTranspose tkTextUpDownLine ::tk::TextUpDownLine tkTraverseToMenu ::tk::TraverseToMenu tkTraverseWithinMenu ::tk::TraverseWithinMenu unsupported1 ::tk::unsupported::MacWindowStyle } # Map from the old global names of Tk private variable to their # new namespace-encapsulated names. variable PrivateVariables array set PrivateVariables { droped_to_start ::tk::mac::Droped_to_start histNum ::tk::HistNum stub_location ::tk::mac::Stub_location tkFocusIn ::tk::FocusIn tkFocusOut ::tk::FocusOut tkPalette ::tk::Palette tkPriv ::tk::Priv tkPrivMsgBox ::tk::PrivMsgBox } } # ::tk::unsupported::ExposePrivateCommand -- # # Expose one of Tk's private commands to be visible under its # old global name # # Arguments: # cmd Global name by which the command was once known, # or a glob-style pattern. # # Results: # None. # # Side effects: # The old command name in the global namespace is aliased to the # new private name. proc ::tk::unsupported::ExposePrivateCommand {cmd} { variable PrivateCommands set cmds [array get PrivateCommands $cmd] if {[llength $cmds] == 0} { return -code error -errorcode {TK EXPOSE_PRIVATE_COMMAND} \ "No compatibility support for \[$cmd]" } foreach {old new} $cmds { namespace eval :: [list interp alias {} $old {}] $new } } # ::tk::unsupported::ExposePrivateVariable -- # # Expose one of Tk's private variables to be visible under its # old global name # # Arguments: # var Global name by which the variable was once known, # or a glob-style pattern. # # Results: # None. # # Side effects: # The old variable name in the global namespace is aliased to the # new private name. proc ::tk::unsupported::ExposePrivateVariable {var} { variable PrivateVariables set vars [array get PrivateVariables $var] if {[llength $vars] == 0} { return -code error -errorcode {TK EXPOSE_PRIVATE_VARIABLE} \ "No compatibility support for \$$var" } namespace eval ::tk::mac {} foreach {old new} $vars { namespace eval :: [list upvar "#0" $new $old] } } tk8.6.8/library/entry.tcl0000644003604700454610000004106613212005724014005 0ustar dgp771div# entry.tcl -- # # This file defines the default bindings for Tk entry widgets and provides # procedures that help in implementing those bindings. # # 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 tk::Priv 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 {tk::EntryGetSelection %W} tk::Priv(data)]} { clipboard clear -displayof %W clipboard append -displayof %W $tk::Priv(data) %W delete sel.first sel.last unset tk::Priv(data) } } bind Entry <> { if {![catch {tk::EntryGetSelection %W} tk::Priv(data)]} { clipboard clear -displayof %W clipboard append -displayof %W $tk::Priv(data) unset tk::Priv(data) } } bind Entry <> { catch { if {[tk windowingsystem] ne "x11"} { catch { %W delete sel.first sel.last } } %W insert insert [::tk::GetSelection %W CLIPBOARD] tk::EntrySeeInsert %W } } bind Entry <> { # ignore if there is no selection catch { %W delete sel.first sel.last } } bind Entry <> { if {$tk_strictMotif || ![info exists tk::Priv(mouseMoved)] || !$tk::Priv(mouseMoved)} { tk::EntryPaste %W %x } } bind Entry <> { %W selection range 0 end %W icursor end } # Standard Motif bindings: bind Entry <1> { tk::EntryButton1 %W %x %W selection clear } bind Entry { set tk::Priv(x) %x tk::EntryMouseSelect %W %x } bind Entry { set tk::Priv(selectMode) word tk::EntryMouseSelect %W %x catch {%W icursor sel.last} } bind Entry { set tk::Priv(selectMode) line tk::EntryMouseSelect %W %x catch {%W icursor sel.last} } bind Entry { set tk::Priv(selectMode) char %W selection adjust @%x } bind Entry { set tk::Priv(selectMode) word tk::EntryMouseSelect %W %x } bind Entry { set tk::Priv(selectMode) line tk::EntryMouseSelect %W %x } bind Entry { set tk::Priv(x) %x tk::EntryAutoScan %W } bind Entry { tk::CancelRepeat } bind Entry { tk::CancelRepeat } bind Entry { %W icursor @%x } bind Entry <> { tk::EntrySetCursor %W [expr {[%W index insert] - 1}] } bind Entry <> { tk::EntrySetCursor %W [expr {[%W index insert] + 1}] } bind Entry <> { tk::EntryKeySelect %W [expr {[%W index insert] - 1}] tk::EntrySeeInsert %W } bind Entry <> { tk::EntryKeySelect %W [expr {[%W index insert] + 1}] tk::EntrySeeInsert %W } bind Entry <> { tk::EntrySetCursor %W [tk::EntryPreviousWord %W insert] } bind Entry <> { tk::EntrySetCursor %W [tk::EntryNextWord %W insert] } bind Entry <> { tk::EntryKeySelect %W [tk::EntryPreviousWord %W insert] tk::EntrySeeInsert %W } bind Entry <> { tk::EntryKeySelect %W [tk::EntryNextWord %W insert] tk::EntrySeeInsert %W } bind Entry <> { tk::EntrySetCursor %W 0 } bind Entry <> { tk::EntryKeySelect %W 0 tk::EntrySeeInsert %W } bind Entry <> { tk::EntrySetCursor %W end } bind Entry <> { tk::EntryKeySelect %W end tk::EntrySeeInsert %W } bind Entry { if {[%W selection present]} { %W delete sel.first sel.last } else { %W delete insert } } bind Entry { tk::EntryBackspace %W } bind Entry { %W selection from insert } bind Entry { tk::ListboxBeginSelect %W [%W index active] } bind Listbox { tk::ListboxBeginExtend %W [%W index active] } bind Listbox { tk::ListboxBeginExtend %W [%W index active] } bind Listbox { tk::ListboxCancel %W } bind Listbox <> { tk::ListboxSelectAll %W } bind Listbox <> { if {[%W cget -selectmode] ne "browse"} { %W selection clear 0 end tk::FireListboxSelectEvent %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 and Mac OS X. # However, someone could use the "event generate" command to produce # one on other platforms. if {[tk windowingsystem] eq "aqua"} { bind Listbox { %W yview scroll [expr {- (%D)}] units } bind Listbox { %W yview scroll [expr {-10 * (%D)}] units } bind Listbox { %W xview scroll [expr {- (%D)}] units } bind Listbox { %W xview scroll [expr {-10 * (%D)}] units } } else { bind Listbox { %W yview scroll [expr {- (%D / 120) * 4}] units } bind Listbox { %W xview scroll [expr {- (%D / 120) * 4}] units } } if {"x11" eq [tk windowingsystem]} { # 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://linuxreviews.org/howtos/xfree/mouse/ bind Listbox <4> { if {!$tk_strictMotif} { %W yview scroll -5 units } } bind Listbox { if {!$tk_strictMotif} { %W xview scroll -5 units } } bind Listbox <5> { if {!$tk_strictMotif} { %W yview scroll 5 units } } bind Listbox { if {!$tk_strictMotif} { %W xview scroll 5 units } } } # ::tk::ListboxBeginSelect -- # # 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 ::tk::ListboxBeginSelect {w el {focus 1}} { variable ::tk::Priv if {[$w cget -selectmode] eq "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 Priv(listboxSelection) {} set Priv(listboxPrev) $el } tk::FireListboxSelectEvent $w # check existence as ListboxSelect may destroy us if {$focus && [winfo exists $w] && [$w cget -state] eq "normal"} { focus $w } } # ::tk::ListboxMotion -- # # 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 ::tk::ListboxMotion {w el} { variable ::tk::Priv if {$el == $Priv(listboxPrev)} { return } set anchor [$w index anchor] switch [$w cget -selectmode] { browse { $w selection clear 0 end $w selection set $el set Priv(listboxPrev) $el tk::FireListboxSelectEvent $w } extended { set i $Priv(listboxPrev) if {$i eq ""} { 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 Priv(listboxSelection)]} { set Priv(listboxSelection) [$w curselection] } while {($i < $el) && ($i < $anchor)} { if {[lsearch $Priv(listboxSelection) $i] >= 0} { $w selection set $i } incr i } while {($i > $el) && ($i > $anchor)} { if {[lsearch $Priv(listboxSelection) $i] >= 0} { $w selection set $i } incr i -1 } set Priv(listboxPrev) $el tk::FireListboxSelectEvent $w } } } # ::tk::ListboxBeginExtend -- # # 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 ::tk::ListboxBeginExtend {w el} { if {[$w cget -selectmode] eq "extended"} { if {[$w selection includes anchor]} { ListboxMotion $w $el } else { # No selection yet; simulate the begin-select operation. ListboxBeginSelect $w $el } } } # ::tk::ListboxBeginToggle -- # # 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 ::tk::ListboxBeginToggle {w el} { variable ::tk::Priv if {[$w cget -selectmode] eq "extended"} { set Priv(listboxSelection) [$w curselection] set Priv(listboxPrev) $el $w selection anchor $el if {[$w selection includes $el]} { $w selection clear $el } else { $w selection set $el } tk::FireListboxSelectEvent $w } } # ::tk::ListboxAutoScan -- # 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 ::tk::ListboxAutoScan {w} { variable ::tk::Priv if {![winfo exists $w]} return set x $Priv(x) set y $Priv(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 } ListboxMotion $w [$w index @$x,$y] set Priv(afterId) [after 50 [list tk::ListboxAutoScan $w]] } # ::tk::ListboxUpDown -- # # 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 ::tk::ListboxUpDown {w amount} { variable ::tk::Priv $w activate [expr {[$w index active] + $amount}] $w see active switch [$w cget -selectmode] { browse { $w selection clear 0 end $w selection set active tk::FireListboxSelectEvent $w } extended { $w selection clear 0 end $w selection set active $w selection anchor active set Priv(listboxPrev) [$w index active] set Priv(listboxSelection) {} tk::FireListboxSelectEvent $w } } } # ::tk::ListboxExtendUpDown -- # # 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 ::tk::ListboxExtendUpDown {w amount} { variable ::tk::Priv if {[$w cget -selectmode] ne "extended"} { return } set active [$w index active] if {![info exists Priv(listboxSelection)]} { $w selection set $active set Priv(listboxSelection) [$w curselection] } $w activate [expr {$active + $amount}] $w see active ListboxMotion $w [$w index active] } # ::tk::ListboxDataExtend # # 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 ::tk::ListboxDataExtend {w el} { set mode [$w cget -selectmode] if {$mode eq "extended"} { $w activate $el $w see $el if {[$w selection includes anchor]} { ListboxMotion $w $el } } elseif {$mode eq "multiple"} { $w activate $el $w see $el } } # ::tk::ListboxCancel # # 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 ::tk::ListboxCancel w { variable ::tk::Priv if {[$w cget -selectmode] ne "extended"} { return } set first [$w index anchor] set last $Priv(listboxPrev) if {$last eq ""} { # 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 $Priv(listboxSelection) $first] >= 0} { $w selection set $first } incr first } tk::FireListboxSelectEvent $w } # ::tk::ListboxSelectAll # # 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 ::tk::ListboxSelectAll w { set mode [$w cget -selectmode] if {$mode eq "single" || $mode eq "browse"} { $w selection clear 0 end $w selection set active } else { $w selection set 0 end } tk::FireListboxSelectEvent $w } # ::tk::FireListboxSelectEvent # # Fire the <> event if the listbox is not in disabled # state. # # Arguments: # w - The listbox widget. proc ::tk::FireListboxSelectEvent w { if {[$w cget -state] eq "normal"} { event generate $w <> } } tk8.6.8/library/menu.tcl0000644003604700454610000011217713212005724013612 0ustar dgp771div# 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. # # 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. # Copyright (c) 2007 Daniel A. Steffen # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # #------------------------------------------------------------------------- # Elements of tk::Priv 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 tk::Priv(oldGrab): if # tk::Priv(oldGrab) is non-empty, then tk::Priv(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 # tk::Priv(postedMb) identifies the posted menubutton. # 2. As a torn-off menu copied from some other menu. In this style # tk::Priv(postedMb) is empty, and menu's type is "tearoff". # 3. As an option menu, triggered from an option menubutton. In this # style tk::Priv(postedMb) identifies the posted menubutton. # 4. As a popup menu. In this style tk::Priv(postedMb) is empty and # the top-level menu's type is "normal". # 5. As a pulldown from a menubar. The variable tk::Priv(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 { tk::MbEnter %W } bind Menubutton { tk::MbLeave %W } bind Menubutton <1> { if {$tk::Priv(inMenubutton) ne ""} { tk::MbPost $tk::Priv(inMenubutton) %X %Y } } bind Menubutton { tk::MbMotion %W up %X %Y } bind Menubutton { tk::MbMotion %W down %X %Y } bind Menubutton { tk::MbButtonUp %W } bind Menubutton { tk::MbPost %W tk::MenuFirstEntry [%W cget -menu] } bind Menubutton <> { tk::MbPost %W tk::MenuFirstEntry [%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 tk::Priv(window) %W if {[%W cget -type] eq "tearoff"} { if {"%m" ne "NotifyUngrab"} { if {[tk windowingsystem] eq "x11"} { tk_menuSetFocus %W } } } tk::MenuMotion %W %x %y %s } bind Menu { tk::MenuLeave %W %X %Y %s } bind Menu { tk::MenuMotion %W %x %y %s } bind Menu { tk::MenuButtonDown %W } bind Menu { tk::MenuInvoke %W 1 } bind Menu { tk::MenuInvoke %W 0 } bind Menu <> { tk::MenuInvoke %W 0 } bind Menu { tk::MenuInvoke %W 0 } bind Menu { tk::MenuEscape %W } bind Menu <> { tk::MenuLeftArrow %W } bind Menu <> { tk::MenuRightArrow %W } bind Menu <> { tk::MenuUpArrow %W } bind Menu <> { tk::MenuDownArrow %W } bind Menu { tk::TraverseWithinMenu %W %A break } # The following bindings apply to all windows, and are used to # implement keyboard menu traversal. if {[tk windowingsystem] eq "x11"} { bind all { tk::TraverseToMenu %W %A } bind all { tk::FirstMenu %W } } else { bind Menubutton { tk::TraverseToMenu %W %A } bind Menubutton { tk::FirstMenu %W } } # ::tk::MbEnter -- # 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 ::tk::MbB1Enter is invoked if the button is down. # # Arguments: # w - The name of the widget. proc ::tk::MbEnter w { variable ::tk::Priv if {$Priv(inMenubutton) ne ""} { MbLeave $Priv(inMenubutton) } set Priv(inMenubutton) $w if {[$w cget -state] ne "disabled" && [tk windowingsystem] ne "aqua"} { $w configure -state active } } # ::tk::MbLeave -- # 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 ::tk::MbLeave w { variable ::tk::Priv set Priv(inMenubutton) {} if {![winfo exists $w]} { return } if {[$w cget -state] eq "active" && [tk windowingsystem] ne "aqua"} { $w configure -state normal } } # ::tk::MbPost -- # 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 ::tk::MbPost {w {x {}} {y {}}} { global errorInfo variable ::tk::Priv if {[$w cget -state] eq "disabled" || $w eq $Priv(postedMb)} { return } set menu [$w cget -menu] if {$menu eq ""} { return } set tearoff [expr {[tk windowingsystem] eq "x11" \ || [$menu cget -type] eq "tearoff"}] if {[string first $w $menu] != 0} { return -code error -errorcode {TK MENUBUTTON POST_NONCHILD} \ "can't post $menu: it isn't a descendant of $w" } set cur $Priv(postedMb) if {$cur ne ""} { MenuUnpost {} } if {$::tk_strictMotif} { set Priv(cursor) [$w cget -cursor] $w configure -cursor arrow } if {[tk windowingsystem] ne "aqua"} { set Priv(relief) [$w cget -relief] $w configure -relief raised } else { $w configure -state active } set Priv(postedMb) $w set Priv(focus) [focus] $menu activate none GenerateMenuSelect $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]}] # if we go offscreen to the top, show as 'below' if {$y < [winfo vrooty $w]} { set y [expr {[winfo vrooty $w] + [winfo rooty $w] + [winfo reqheight $w]}] } PostOverPoint $menu $x $y } below { set x [winfo rootx $w] set y [expr {[winfo rooty $w] + [winfo height $w]}] # if we go offscreen to the bottom, show as 'above' set mh [winfo reqheight $menu] if {($y + $mh) > ([winfo vrooty $w] + [winfo vrootheight $w])} { set y [expr {[winfo vrooty $w] + [winfo vrootheight $w] + [winfo rooty $w] - $mh}] } PostOverPoint $menu $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 [MenuFindName $menu [$w cget -text]] if {$entry eq ""} { set entry 0 } 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}] } } PostOverPoint $menu $x $y if {$entry ne "" \ && [$menu entrycget $entry -state] ne "disabled"} { $menu activate $entry GenerateMenuSelect $menu } } right { set x [expr {[winfo rootx $w] + [winfo width $w]}] set y [expr {(2 * [winfo rooty $w] + [winfo height $w]) / 2}] set entry [MenuFindName $menu [$w cget -text]] if {$entry eq ""} { set entry 0 } 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}] } } PostOverPoint $menu $x $y if {$entry ne "" \ && [$menu entrycget $entry -state] ne "disabled"} { $menu activate $entry GenerateMenuSelect $menu } } default { if {[$w cget -indicatoron]} { if {$y eq ""} { set x [expr {[winfo rootx $w] + [winfo width $w]/2}] set y [expr {[winfo rooty $w] + [winfo height $w]/2}] } PostOverPoint $menu $x $y [MenuFindName $menu [$w cget -text]] } else { PostOverPoint $menu [winfo rootx $w] [expr {[winfo rooty $w]+[winfo height $w]}] } } } } msg opt]} { # Error posting menu (e.g. bogus -postcommand). Unpost it and # reflect the error. MenuUnpost {} return -options $opt $msg } set Priv(tearoff) $tearoff if {$tearoff != 0} { focus $menu if {[winfo viewable $w]} { SaveGrabInfo $w grab -global $w } } } # ::tk::MenuUnpost -- # 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 ::tk::MenuUnpost menu { variable ::tk::Priv set mb $Priv(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 $Priv(focus)} set Priv(focus) "" # Unpost menu(s) and restore some stuff that's dependent on # what was posted. after cancel [array get Priv menuActivatedTimer] unset -nocomplain Priv(menuActivated) after cancel [array get Priv menuDeactivatedTimer] unset -nocomplain Priv(menuDeactivated) catch { if {$mb ne ""} { set menu [$mb cget -menu] $menu unpost set Priv(postedMb) {} if {$::tk_strictMotif} { $mb configure -cursor $Priv(cursor) } if {[tk windowingsystem] ne "aqua"} { $mb configure -relief $Priv(relief) } else { $mb configure -state normal } } elseif {$Priv(popup) ne ""} { $Priv(popup) unpost set Priv(popup) {} } elseif {[$menu cget -type] ne "menubar" && [$menu cget -type] ne "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 {[winfo class $parent] ne "Menu" || ![winfo ismapped $parent]} { break } $parent activate none $parent postcascade none GenerateMenuSelect $parent set type [$parent cget -type] if {$type eq "menubar" || $type eq "tearoff"} { break } set menu $parent } if {[$menu cget -type] ne "menubar"} { $menu unpost } } } if {($Priv(tearoff) != 0) || $Priv(menuBar) ne ""} { # Release grab, if any, and restore the previous grab, if there # was one. if {$menu ne ""} { set grab [grab current $menu] if {$grab ne ""} { grab release $grab } } RestoreOldGrab if {$Priv(menuBar) ne ""} { if {$::tk_strictMotif} { $Priv(menuBar) configure -cursor $Priv(cursor) } set Priv(menuBar) {} } if {[tk windowingsystem] ne "x11"} { set Priv(tearoff) 0 } } } # ::tk::MbMotion -- # 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 ::tk::MbMotion {w upDown rootx rooty} { variable ::tk::Priv if {$Priv(inMenubutton) eq $w} { return } set new [winfo containing $rootx $rooty] if {$new ne $Priv(inMenubutton) \ && ($new eq "" || [winfo toplevel $new] eq [winfo toplevel $w])} { if {$Priv(inMenubutton) ne ""} { MbLeave $Priv(inMenubutton) } if {$new ne "" \ && [winfo class $new] eq "Menubutton" \ && ([$new cget -indicatoron] == 0) \ && ([$w cget -indicatoron] == 0)} { if {$upDown eq "down"} { MbPost $new $rootx $rooty } else { MbEnter $new } } } } # ::tk::MbButtonUp -- # 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 ::tk::MbButtonUp w { variable ::tk::Priv set menu [$w cget -menu] set tearoff [expr {[tk windowingsystem] eq "x11" || \ ($menu ne "" && [$menu cget -type] eq "tearoff")}] if {($tearoff != 0) && $Priv(postedMb) eq $w \ && $Priv(inMenubutton) eq $w} { MenuFirstEntry [$Priv(postedMb) cget -menu] } else { MenuUnpost {} } } # ::tk::MenuMotion -- # 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 ::tk::MenuMotion {menu x y state} { variable ::tk::Priv if {$menu eq $Priv(window)} { set activeindex [$menu index active] if {[$menu cget -type] eq "menubar"} { if {[info exists Priv(focus)] && $menu ne $Priv(focus)} { $menu activate @$x,$y GenerateMenuSelect $menu } } else { $menu activate @$x,$y GenerateMenuSelect $menu } set index [$menu index @$x,$y] if {[info exists Priv(menuActivated)] \ && $index ne "none" \ && $index ne $activeindex} { set mode [option get $menu clickToFocus ClickToFocus] if {[string is false $mode]} { set delay [expr {[$menu cget -type] eq "menubar" ? 0 : 50}] if {[$menu type $index] eq "cascade"} { set Priv(menuActivatedTimer) \ [after $delay [list $menu postcascade active]] } else { set Priv(menuDeactivatedTimer) \ [after $delay [list $menu postcascade none]] } } } } } # ::tk::MenuButtonDown -- # 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 ::tk::MenuButtonDown menu { variable ::tk::Priv if {![winfo viewable $menu]} { return } if {[$menu index active] eq "none"} { set Priv(window) {} return } $menu postcascade active if {$Priv(postedMb) ne "" && [winfo viewable $Priv(postedMb)]} { grab -global $Priv(postedMb) } else { while {[$menu cget -type] eq "normal" \ && [winfo class [winfo parent $menu]] eq "Menu" \ && [winfo ismapped [winfo parent $menu]]} { set menu [winfo parent $menu] } if {$Priv(menuBar) eq {}} { set Priv(menuBar) $menu if {$::tk_strictMotif} { set Priv(cursor) [$menu cget -cursor] $menu configure -cursor arrow } if {[$menu type active] eq "cascade"} { set Priv(menuActivated) 1 } } # 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 {$menu ne [grab current $menu]} { SaveGrabInfo $menu } # Must re-grab even if the grab window hasn't changed, in order # to release the implicit grab from the button press. if {[tk windowingsystem] eq "x11"} { grab -global $menu } } } # ::tk::MenuLeave -- # 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 ::tk::MenuLeave {menu rootx rooty state} { variable ::tk::Priv set Priv(window) {} if {[$menu index active] eq "none"} { return } if {[$menu type active] eq "cascade" \ && [winfo containing $rootx $rooty] eq \ [$menu entrycget active -menu]} { return } $menu activate none GenerateMenuSelect $menu } # ::tk::MenuInvoke -- # 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 ::tk::MenuInvoke {w buttonRelease} { variable ::tk::Priv if {$buttonRelease && $Priv(window) eq ""} { # 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 <> MenuUnpost $w return } if {[$w type active] eq "cascade"} { $w postcascade active set menu [$w entrycget active -menu] MenuFirstEntry $menu } elseif {[$w type active] eq "tearoff"} { ::tk::TearOffMenu $w MenuUnpost $w } elseif {[$w cget -type] eq "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 <> } MenuUnpost $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 { set active [$w index active] if {$Priv(popup) eq "" || $active ne "none"} { MenuUnpost $w } uplevel #0 [list $w invoke active] } } # ::tk::MenuEscape -- # 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 ::tk::MenuEscape menu { set parent [winfo parent $menu] if {[winfo class $parent] ne "Menu"} { MenuUnpost $menu } elseif {[$parent cget -type] eq "menubar"} { MenuUnpost $menu RestoreOldGrab } else { MenuNextMenu $menu left } } # The following routines handle arrow keys. Arrow keys behave # differently depending on whether the menu is a menu bar or not. proc ::tk::MenuUpArrow {menu} { if {[$menu cget -type] eq "menubar"} { MenuNextMenu $menu left } else { MenuNextEntry $menu -1 } } proc ::tk::MenuDownArrow {menu} { if {[$menu cget -type] eq "menubar"} { MenuNextMenu $menu right } else { MenuNextEntry $menu 1 } } proc ::tk::MenuLeftArrow {menu} { if {[$menu cget -type] eq "menubar"} { MenuNextEntry $menu -1 } else { MenuNextMenu $menu left } } proc ::tk::MenuRightArrow {menu} { if {[$menu cget -type] eq "menubar"} { MenuNextEntry $menu 1 } else { MenuNextMenu $menu right } } # ::tk::MenuNextMenu -- # 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 ::tk::MenuNextMenu {menu direction} { variable ::tk::Priv # First handle traversals into and out of cascaded menus. if {$direction eq "right"} { set count 1 set parent [winfo parent $menu] set class [winfo class $parent] if {[$menu type active] eq "cascade"} { $menu postcascade active set m2 [$menu entrycget active -menu] if {$m2 ne ""} { MenuFirstEntry $m2 } return } else { set parent [winfo parent $menu] while {$parent ne "."} { if {[winfo class $parent] eq "Menu" \ && [$parent cget -type] eq "menubar"} { tk_menuSetFocus $parent MenuNextEntry $parent 1 return } set parent [winfo parent $parent] } } } else { set count -1 set m2 [winfo parent $menu] if {[winfo class $m2] eq "Menu"} { $menu activate none GenerateMenuSelect $menu tk_menuSetFocus $m2 $m2 postcascade none if {[$m2 cget -type] ne "menubar"} { 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 {[winfo class $m2] eq "Menu" && [$m2 cget -type] eq "menubar"} { tk_menuSetFocus $m2 MenuNextEntry $m2 -1 return } set w $Priv(postedMb) if {$w eq ""} { 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 {[winfo class $mb] eq "Menubutton" \ && [$mb cget -state] ne "disabled" \ && [$mb cget -menu] ne "" \ && [[$mb cget -menu] index last] ne "none"} { break } if {$mb eq $w} { return } incr i $count } MbPost $mb MenuFirstEntry [$mb cget -menu] } # ::tk::MenuNextEntry -- # 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 ::tk::MenuNextEntry {menu count} { if {[$menu index last] eq "none"} { return } set length [expr {[$menu index last]+1}] set quitAfter $length set active [$menu index active] if {$active eq "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 {$state ne "disabled" && \ ($i!=0 || [$menu cget -type] ne "tearoff" \ || [$menu type 0] ne "tearoff")} { break } } if {$i == $active} { return } incr i $count incr quitAfter -1 } $menu activate $i GenerateMenuSelect $menu if {[$menu type $i] eq "cascade" && [$menu cget -type] eq "menubar"} { set cascade [$menu entrycget $i -menu] if {$cascade ne ""} { # 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 MenuFirstEntry $cascade } } } # ::tk::MenuFind -- # 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 ::tk::MenuFind {w char} { set char [string tolower $char] set windowlist [winfo child $w] foreach child $windowlist { # Don't descend into other toplevels. if {[winfo toplevel $w] ne [winfo toplevel $child]} { continue } if {[winfo class $child] eq "Menu" && \ [$child cget -type] eq "menubar"} { if {$char eq ""} { return $child } set last [$child index last] for {set i [$child cget -tearoff]} {$i <= $last} {incr i} { if {[$child type $i] eq "separator"} { continue } set char2 [string index [$child entrycget $i -label] \ [$child entrycget $i -underline]] if {$char eq [string tolower $char2] || $char eq ""} { if {[$child entrycget $i -state] ne "disabled"} { return $child } } } } } foreach child $windowlist { # Don't descend into other toplevels. if {[winfo toplevel $w] ne [winfo toplevel $child]} { continue } switch -- [winfo class $child] { Menubutton { set char2 [string index [$child cget -text] \ [$child cget -underline]] if {$char eq [string tolower $char2] || $char eq ""} { if {[$child cget -state] ne "disabled"} { return $child } } } default { set match [MenuFind $child $char] if {$match ne ""} { return $match } } } } return {} } # ::tk::TraverseToMenu -- # 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 ::tk::TraverseToMenu {w char} { variable ::tk::Priv if {![winfo exists $w] || $char eq ""} { return } while {[winfo class $w] eq "Menu"} { if {[$w cget -type] eq "menubar"} { break } elseif {$Priv(postedMb) eq ""} { return } set w [winfo parent $w] } set w [MenuFind [winfo toplevel $w] $char] if {$w ne ""} { if {[winfo class $w] eq "Menu"} { tk_menuSetFocus $w set Priv(window) $w SaveGrabInfo $w grab -global $w TraverseWithinMenu $w $char } else { MbPost $w MenuFirstEntry [$w cget -menu] } } } # ::tk::FirstMenu -- # 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 ::tk::FirstMenu w { variable ::tk::Priv set w [MenuFind [winfo toplevel $w] ""] if {$w ne ""} { if {[winfo class $w] eq "Menu"} { tk_menuSetFocus $w set Priv(window) $w SaveGrabInfo $w grab -global $w MenuFirstEntry $w } else { MbPost $w MenuFirstEntry [$w cget -menu] } } } # ::tk::TraverseWithinMenu # 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 ::tk::TraverseWithinMenu {w char} { if {$char eq ""} { return } set char [string tolower $char] set last [$w index last] if {$last eq "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 {$char eq [string tolower $char2]} { if {[$w type $i] eq "cascade"} { $w activate $i $w postcascade active event generate $w <> set m2 [$w entrycget $i -menu] if {$m2 ne ""} { MenuFirstEntry $m2 } } else { MenuUnpost $w uplevel #0 [list $w invoke $i] } return } } } # ::tk::MenuFirstEntry -- # 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 tk::PostOverPoint) 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 ::tk::MenuFirstEntry menu { if {$menu eq ""} { return } tk_menuSetFocus $menu if {[$menu index active] ne "none"} { return } set last [$menu index last] if {$last eq "none"} { return } for {set i 0} {$i <= $last} {incr i} { if {([catch {set state [$menu entrycget $i -state]}] == 0) \ && $state ne "disabled" && [$menu type $i] ne "tearoff"} { $menu activate $i GenerateMenuSelect $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 {[$menu type $i] eq "cascade" && [$menu cget -type] eq "menubar"} { set cascade [$menu entrycget $i -menu] if {$cascade ne ""} { $menu postcascade $i MenuFirstEntry $cascade } } return } } } # ::tk::MenuFindName -- # 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 ::tk::MenuFindName {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 {$last eq "none"} { return } for {set i 0} {$i <= $last} {incr i} { if {![catch {$menu entrycget $i -label} label]} { if {$label eq $s} { return $i } } } return "" } # ::tk::PostOverPoint -- # 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 ::tk::PostOverPoint {menu x y {entry {}}} { if {$entry ne ""} { 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}] } if {[tk windowingsystem] eq "win32"} { # osVersion is not available in safe interps set ver 5 if {[info exists ::tcl_platform(osVersion)]} { scan $::tcl_platform(osVersion) %d ver } # We need to fix some problems with menu posting on Windows, # where, if the menu would overlap top or bottom of screen, # Windows puts it in the wrong place for us. We must also # subtract an extra amount for half the height of the current # entry. To be safe we subtract an extra 10. # NOTE: this issue appears to have been resolved in the Window # manager provided with Vista and Windows 7. if {$ver < 6} { set yoffset [expr {[winfo screenheight $menu] \ - $y - [winfo reqheight $menu] - 10}] if {$yoffset < [winfo vrooty $menu]} { # The bottom of the menu is offscreen, so adjust upwards incr y [expr {$yoffset - [winfo vrooty $menu]}] } # If we're off the top of the screen (either because we were # originally or because we just adjusted too far upwards), # then make the menu popup on the top edge. if {$y < [winfo vrooty $menu]} { set y [winfo vrooty $menu] } } } $menu post $x $y if {$entry ne "" && [$menu entrycget $entry -state] ne "disabled"} { $menu activate $entry GenerateMenuSelect $menu } } # ::tk::SaveGrabInfo -- # Sets the variables tk::Priv(oldGrab) and tk::Priv(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 tk::SaveGrabInfo w { variable ::tk::Priv set Priv(oldGrab) [grab current $w] if {$Priv(oldGrab) ne ""} { set Priv(grabStatus) [grab status $Priv(oldGrab)] } } # ::tk::RestoreOldGrab -- # Restores the grab to what it was before TkSaveGrabInfo was called. # proc ::tk::RestoreOldGrab {} { variable ::tk::Priv if {$Priv(oldGrab) ne ""} { # Be careful restoring the old grab, since it's window may not # be visible anymore. catch { if {$Priv(grabStatus) eq "global"} { grab set -global $Priv(oldGrab) } else { grab set $Priv(oldGrab) } } set Priv(oldGrab) "" } } proc ::tk_menuSetFocus {menu} { variable ::tk::Priv if {![info exists Priv(focus)] || $Priv(focus) eq ""} { set Priv(focus) [focus] } focus $menu } proc ::tk::GenerateMenuSelect {menu} { variable ::tk::Priv if {$Priv(activeMenu) eq $menu \ && $Priv(activeItem) eq [$menu index active]} { return } set Priv(activeMenu) $menu set Priv(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 {}}} { variable ::tk::Priv if {$Priv(popup) ne "" || $Priv(postedMb) ne ""} { tk::MenuUnpost {} } tk::PostOverPoint $menu $x $y $entry if {[tk windowingsystem] eq "x11" && [winfo viewable $menu]} { tk::SaveGrabInfo $menu grab -global $menu set Priv(popup) $menu set Priv(window) $menu set Priv(menuActivated) 1 tk_menuSetFocus $menu } } tk8.6.8/library/bgerror.tcl0000644003604700454610000002006613212005724014303 0ustar dgp771div# bgerror.tcl -- # # Implementation of the bgerror procedure. It posts a dialog box with # the error message and gives the user a chance to see a more detailed # stack trace, and possible do something more interesting with that # trace (like save it to a log). This is adapted from work done by # Donal K. Fellows. # # Copyright (c) 1998-2000 by Ajuba Solutions. # Copyright (c) 2007 by ActiveState Software Inc. # Copyright (c) 2007 Daniel A. Steffen # Copyright (c) 2009 Pat Thoyts namespace eval ::tk::dialog::error { namespace import -force ::tk::msgcat::* namespace export bgerror option add *ErrorDialog.function.text [mc "Save To Log"] \ widgetDefault option add *ErrorDialog.function.command [namespace code SaveToLog] option add *ErrorDialog*Label.font TkCaptionFont widgetDefault if {[tk windowingsystem] eq "aqua"} { option add *ErrorDialog*background systemAlertBackgroundActive \ widgetDefault option add *ErrorDialog*info.text.background white widgetDefault option add *ErrorDialog*Button.highlightBackground \ systemAlertBackgroundActive widgetDefault } } proc ::tk::dialog::error::Return {which code} { variable button .bgerrorDialog.$which state {active selected focus} update idletasks after 100 set button $code } proc ::tk::dialog::error::Details {} { set w .bgerrorDialog set caption [option get $w.function text {}] set command [option get $w.function command {}] if { ($caption eq "") || ($command eq "") } { grid forget $w.function } lappend command [$w.top.info.text get 1.0 end-1c] $w.function configure -text $caption -command $command grid $w.top.info - -sticky nsew -padx 3m -pady 3m } proc ::tk::dialog::error::SaveToLog {text} { if { $::tcl_platform(platform) eq "windows" } { set allFiles *.* } else { set allFiles * } set types [list \ [list [mc "Log Files"] .log] \ [list [mc "Text Files"] .txt] \ [list [mc "All Files"] $allFiles] \ ] set filename [tk_getSaveFile -title [mc "Select Log File"] \ -filetypes $types -defaultextension .log -parent .bgerrorDialog] if {$filename ne {}} { set f [open $filename w] puts -nonewline $f $text close $f } return } proc ::tk::dialog::error::Destroy {w} { if {$w eq ".bgerrorDialog"} { variable button set button -1 } } proc ::tk::dialog::error::DeleteByProtocol {} { variable button set button 1 } proc ::tk::dialog::error::ReturnInDetails w { bind $w {}; # Remove this binding $w invoke return -code break } # ::tk::dialog::error::bgerror -- # # This is the default version of bgerror. # It tries to execute tkerror, if that fails it posts a dialog box # containing the error message and gives the user a chance to ask # to see a stack trace. # # Arguments: # err - The error message. # proc ::tk::dialog::error::bgerror err { global errorInfo variable button set info $errorInfo set ret [catch {::tkerror $err} msg]; if {$ret != 1} {return -code $ret $msg} # Ok the application's tkerror either failed or was not found # we use the default dialog then : set windowingsystem [tk windowingsystem] if {$windowingsystem eq "aqua"} { set ok [mc Ok] } else { set ok [mc OK] } # Truncate the message if it is too wide (>maxLine characters) or # too tall (>4 lines). Truncation occurs at the first point at # which one of those conditions is met. set displayedErr "" set lines 0 set maxLine 45 foreach line [split $err \n] { if { [string length $line] > $maxLine } { append displayedErr "[string range $line 0 [expr {$maxLine-3}]]..." break } if { $lines > 4 } { append displayedErr "..." break } else { append displayedErr "${line}\n" } incr lines } set title [mc "Application Error"] set text [mc "Error: %1\$s" $displayedErr] set buttons [list ok $ok dismiss [mc "Skip Messages"] \ function [mc "Details >>"]] # 1. Create the top-level window and divide it into top # and bottom parts. set dlg .bgerrorDialog set bg [ttk::style lookup . -background] destroy $dlg toplevel $dlg -class ErrorDialog -background $bg wm withdraw $dlg wm title $dlg $title wm iconname $dlg ErrorDialog wm protocol $dlg WM_DELETE_WINDOW [namespace code DeleteByProtocol] if {$windowingsystem eq "aqua"} { ::tk::unsupported::MacWindowStyle style $dlg moveableAlert {} } elseif {$windowingsystem eq "x11"} { wm attributes $dlg -type dialog } ttk::frame $dlg.bot ttk::frame $dlg.top pack $dlg.bot -side bottom -fill both pack $dlg.top -side top -fill both -expand 1 set W [ttk::frame $dlg.top.info] text $W.text -setgrid true -height 10 -wrap char \ -yscrollcommand [list $W.scroll set] if {$windowingsystem ne "aqua"} { $W.text configure -width 40 } ttk::scrollbar $W.scroll -command [list $W.text yview] pack $W.scroll -side right -fill y pack $W.text -side left -expand yes -fill both $W.text insert 0.0 "$err\n$info" $W.text mark set insert 0.0 bind $W.text { focus %W } $W.text configure -state disabled # 2. Fill the top part with bitmap and message # Max-width of message is the width of the screen... set wrapwidth [winfo screenwidth $dlg] # ...minus the width of the icon, padding and a fudge factor for # the window manager decorations and aesthetics. set wrapwidth [expr {$wrapwidth-60-[winfo pixels $dlg 9m]}] ttk::label $dlg.msg -justify left -text $text -wraplength $wrapwidth ttk::label $dlg.bitmap -image ::tk::icons::error grid $dlg.bitmap $dlg.msg -in $dlg.top -row 0 -padx 3m -pady 3m grid configure $dlg.bitmap -sticky ne grid configure $dlg.msg -sticky nsw -padx {0 3m} grid rowconfigure $dlg.top 1 -weight 1 grid columnconfigure $dlg.top 1 -weight 1 # 3. Create a row of buttons at the bottom of the dialog. set i 0 foreach {name caption} $buttons { ttk::button $dlg.$name -text $caption -default normal \ -command [namespace code [list set button $i]] grid $dlg.$name -in $dlg.bot -column $i -row 0 -sticky ew -padx 10 grid columnconfigure $dlg.bot $i -weight 1 # We boost the size of some Mac buttons for l&f if {$windowingsystem eq "aqua"} { if {($name eq "ok") || ($name eq "dismiss")} { grid columnconfigure $dlg.bot $i -minsize 90 } grid configure $dlg.$name -pady 7 } incr i } # The "OK" button is the default for this dialog. $dlg.ok configure -default active bind $dlg [namespace code {Return ok 0}] bind $dlg [namespace code {Return dismiss 1}] bind $dlg [namespace code {Destroy %W}] bind $dlg.function [namespace code {ReturnInDetails %W}] $dlg.function configure -command [namespace code Details] # 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 (Motif style) and de-iconify it. ::tk::PlaceWindow $dlg # 7. Set a grab and claim the focus too. ::tk::SetFocusGrab $dlg $dlg.ok # 8. Ensure that we are topmost. raise $dlg if {[tk windowingsystem] eq "win32"} { # Place it topmost if we aren't at the top of the stacking # order to ensure that it's seen if {[lindex [wm stackorder .] end] ne "$dlg"} { wm attributes $dlg -topmost 1 } } # 9. 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. vwait [namespace which -variable button] set copy $button; # Save a copy... ::tk::RestoreFocusGrab $dlg $dlg.ok destroy if {$copy == 1} { return -code break } } namespace eval :: { # Fool the indexer proc bgerror err {} rename bgerror {} namespace import ::tk::dialog::error::bgerror } tk8.6.8/library/button.tcl0000644003604700454610000005024213212005724014153 0ustar dgp771div# 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. # # Copyright (c) 1992-1994 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 2002 ActiveState Corporation. # # 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 {[tk windowingsystem] eq "aqua"} { bind Radiobutton { tk::ButtonEnter %W } bind Radiobutton <1> { tk::ButtonDown %W } bind Radiobutton { tk::ButtonUp %W } bind Checkbutton { tk::ButtonEnter %W } bind Checkbutton <1> { tk::ButtonDown %W } bind Checkbutton { tk::ButtonUp %W } bind Checkbutton { tk::ButtonLeave %W } } if {"win32" eq [tk windowingsystem]} { bind Checkbutton { tk::CheckRadioInvoke %W select } bind Checkbutton { tk::CheckRadioInvoke %W select } bind Checkbutton { tk::CheckRadioInvoke %W deselect } bind Checkbutton <1> { tk::CheckRadioDown %W } bind Checkbutton { tk::ButtonUp %W } bind Checkbutton { tk::CheckRadioEnter %W } bind Checkbutton { tk::ButtonLeave %W } bind Radiobutton <1> { tk::CheckRadioDown %W } bind Radiobutton { tk::ButtonUp %W } bind Radiobutton { tk::CheckRadioEnter %W } } if {"x11" eq [tk windowingsystem]} { bind Checkbutton { if {!$tk_strictMotif} { tk::CheckInvoke %W } } bind Radiobutton { if {!$tk_strictMotif} { tk::CheckRadioInvoke %W } } bind Checkbutton <1> { tk::CheckInvoke %W } bind Radiobutton <1> { tk::CheckRadioInvoke %W } bind Checkbutton { tk::CheckEnter %W } bind Radiobutton { tk::ButtonEnter %W } bind Checkbutton { tk::CheckLeave %W } } bind Button { tk::ButtonInvoke %W } bind Checkbutton { tk::CheckRadioInvoke %W } bind Radiobutton { tk::CheckRadioInvoke %W } bind Button <> { tk::ButtonInvoke %W } bind Checkbutton <> { tk::CheckRadioInvoke %W } bind Radiobutton <> { tk::CheckRadioInvoke %W } bind Button {} bind Button { tk::ButtonEnter %W } bind Button { tk::ButtonLeave %W } bind Button <1> { tk::ButtonDown %W } bind Button { tk::ButtonUp %W } bind Checkbutton {} bind Radiobutton {} bind Radiobutton { tk::ButtonLeave %W } if {"win32" eq [tk windowingsystem]} { ######################### # Windows implementation ######################### # ::tk::ButtonEnter -- # 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 ::tk::ButtonEnter w { variable ::tk::Priv if {[$w cget -state] ne "disabled"} { # If the mouse button is down, set the relief to sunken on entry. # Overwise, if there's an -overrelief value, set the relief to that. set Priv($w,relief) [$w cget -relief] if {$Priv(buttonWindow) eq $w} { $w configure -relief sunken -state active set Priv($w,prelief) sunken } elseif {[set over [$w cget -overrelief]] ne ""} { $w configure -relief $over set Priv($w,prelief) $over } } set Priv(window) $w } # ::tk::ButtonLeave -- # The procedure below is invoked when the mouse pointer leaves a # button widget. It changes the state of the button back to inactive. # Restore any modified relief too. # # Arguments: # w - The name of the widget. proc ::tk::ButtonLeave w { variable ::tk::Priv if {[$w cget -state] ne "disabled"} { $w configure -state normal } # Restore the original button relief if it was changed by Tk. # That is signaled by the existence of Priv($w,prelief). if {[info exists Priv($w,relief)]} { if {[info exists Priv($w,prelief)] && \ $Priv($w,prelief) eq [$w cget -relief]} { $w configure -relief $Priv($w,relief) } unset -nocomplain Priv($w,relief) Priv($w,prelief) } set Priv(window) "" } # ::tk::ButtonDown -- # 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 ::tk::ButtonDown w { variable ::tk::Priv # Only save the button's relief if it does not yet exist. If there # is an overrelief setting, Priv($w,relief) will already have been set, # and the current value of the -relief option will be incorrect. if {![info exists Priv($w,relief)]} { set Priv($w,relief) [$w cget -relief] } if {[$w cget -state] ne "disabled"} { set Priv(buttonWindow) $w $w configure -relief sunken -state active set Priv($w,prelief) sunken # If this button has a repeatdelay set up, get it going with an after after cancel $Priv(afterId) set delay [$w cget -repeatdelay] set Priv(repeated) 0 if {$delay > 0} { set Priv(afterId) [after $delay [list tk::ButtonAutoInvoke $w]] } } } # ::tk::ButtonUp -- # 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 ::tk::ButtonUp w { variable ::tk::Priv if {$Priv(buttonWindow) eq $w} { set Priv(buttonWindow) "" # Restore the button's relief if it was cached. if {[info exists Priv($w,relief)]} { if {[info exists Priv($w,prelief)] && \ $Priv($w,prelief) eq [$w cget -relief]} { $w configure -relief $Priv($w,relief) } unset -nocomplain Priv($w,relief) Priv($w,prelief) } # Clean up the after event from the auto-repeater after cancel $Priv(afterId) if {$Priv(window) eq $w && [$w cget -state] ne "disabled"} { $w configure -state normal # Only invoke the command if it wasn't already invoked by the # auto-repeater functionality if { $Priv(repeated) == 0 } { uplevel #0 [list $w invoke] } } } } # ::tk::CheckRadioEnter -- # 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 ::tk::CheckRadioEnter w { variable ::tk::Priv if {[$w cget -state] ne "disabled"} { if {$Priv(buttonWindow) eq $w} { $w configure -state active } if {[set over [$w cget -overrelief]] ne ""} { set Priv($w,relief) [$w cget -relief] set Priv($w,prelief) $over $w configure -relief $over } } set Priv(window) $w } # ::tk::CheckRadioDown -- # 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 ::tk::CheckRadioDown w { variable ::tk::Priv if {![info exists Priv($w,relief)]} { set Priv($w,relief) [$w cget -relief] } if {[$w cget -state] ne "disabled"} { set Priv(buttonWindow) $w set Priv(repeated) 0 $w configure -state active } } } if {"x11" eq [tk windowingsystem]} { ##################### # Unix implementation ##################### # ::tk::ButtonEnter -- # 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 ::tk::ButtonEnter {w} { variable ::tk::Priv if {[$w cget -state] ne "disabled"} { # On unix the state is active just with mouse-over $w configure -state active # If the mouse button is down, set the relief to sunken on entry. # Overwise, if there's an -overrelief value, set the relief to that. set Priv($w,relief) [$w cget -relief] if {$Priv(buttonWindow) eq $w} { $w configure -relief sunken set Priv($w,prelief) sunken } elseif {[set over [$w cget -overrelief]] ne ""} { $w configure -relief $over set Priv($w,prelief) $over } } set Priv(window) $w } # ::tk::ButtonLeave -- # The procedure below is invoked when the mouse pointer leaves a # button widget. It changes the state of the button back to inactive. # Restore any modified relief too. # # Arguments: # w - The name of the widget. proc ::tk::ButtonLeave w { variable ::tk::Priv if {[$w cget -state] ne "disabled"} { $w configure -state normal } # Restore the original button relief if it was changed by Tk. # That is signaled by the existence of Priv($w,prelief). if {[info exists Priv($w,relief)]} { if {[info exists Priv($w,prelief)] && \ $Priv($w,prelief) eq [$w cget -relief]} { $w configure -relief $Priv($w,relief) } unset -nocomplain Priv($w,relief) Priv($w,prelief) } set Priv(window) "" } # ::tk::ButtonDown -- # 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 ::tk::ButtonDown w { variable ::tk::Priv # Only save the button's relief if it does not yet exist. If there # is an overrelief setting, Priv($w,relief) will already have been set, # and the current value of the -relief option will be incorrect. if {![info exists Priv($w,relief)]} { set Priv($w,relief) [$w cget -relief] } if {[$w cget -state] ne "disabled"} { set Priv(buttonWindow) $w $w configure -relief sunken set Priv($w,prelief) sunken # If this button has a repeatdelay set up, get it going with an after after cancel $Priv(afterId) set delay [$w cget -repeatdelay] set Priv(repeated) 0 if {$delay > 0} { set Priv(afterId) [after $delay [list tk::ButtonAutoInvoke $w]] } } } # ::tk::ButtonUp -- # 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 ::tk::ButtonUp w { variable ::tk::Priv if {$w eq $Priv(buttonWindow)} { set Priv(buttonWindow) "" # Restore the button's relief if it was cached. if {[info exists Priv($w,relief)]} { if {[info exists Priv($w,prelief)] && \ $Priv($w,prelief) eq [$w cget -relief]} { $w configure -relief $Priv($w,relief) } unset -nocomplain Priv($w,relief) Priv($w,prelief) } # Clean up the after event from the auto-repeater after cancel $Priv(afterId) if {$Priv(window) eq $w && [$w cget -state] ne "disabled"} { # Only invoke the command if it wasn't already invoked by the # auto-repeater functionality if { $Priv(repeated) == 0 } { uplevel #0 [list $w invoke] } } } } } if {[tk windowingsystem] eq "aqua"} { #################### # Mac implementation #################### # ::tk::ButtonEnter -- # 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 ::tk::ButtonEnter {w} { variable ::tk::Priv if {[$w cget -state] ne "disabled"} { # If there's an -overrelief value, set the relief to that. if {$Priv(buttonWindow) eq $w} { $w configure -state active } elseif {[set over [$w cget -overrelief]] ne ""} { set Priv($w,relief) [$w cget -relief] set Priv($w,prelief) $over $w configure -relief $over } } set Priv(window) $w } # ::tk::ButtonLeave -- # 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 (Priv(buttonWindow) == $w), restore the relief of the # button too. # # Arguments: # w - The name of the widget. proc ::tk::ButtonLeave w { variable ::tk::Priv if {$w eq $Priv(buttonWindow)} { $w configure -state normal } # Restore the original button relief if it was changed by Tk. # That is signaled by the existence of Priv($w,prelief). if {[info exists Priv($w,relief)]} { if {[info exists Priv($w,prelief)] && \ $Priv($w,prelief) eq [$w cget -relief]} { $w configure -relief $Priv($w,relief) } unset -nocomplain Priv($w,relief) Priv($w,prelief) } set Priv(window) "" } # ::tk::ButtonDown -- # 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 ::tk::ButtonDown w { variable ::tk::Priv if {[$w cget -state] ne "disabled"} { set Priv(buttonWindow) $w $w configure -state active # If this button has a repeatdelay set up, get it going with an after after cancel $Priv(afterId) set Priv(repeated) 0 if { ![catch {$w cget -repeatdelay} delay] } { if {$delay > 0} { set Priv(afterId) [after $delay [list tk::ButtonAutoInvoke $w]] } } } } # ::tk::ButtonUp -- # 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 ::tk::ButtonUp w { variable ::tk::Priv if {$Priv(buttonWindow) eq $w} { set Priv(buttonWindow) "" $w configure -state normal # Restore the button's relief if it was cached. if {[info exists Priv($w,relief)]} { if {[info exists Priv($w,prelief)] && \ $Priv($w,prelief) eq [$w cget -relief]} { $w configure -relief $Priv($w,relief) } unset -nocomplain Priv($w,relief) Priv($w,prelief) } # Clean up the after event from the auto-repeater after cancel $Priv(afterId) if {$Priv(window) eq $w && [$w cget -state] ne "disabled"} { # Only invoke the command if it wasn't already invoked by the # auto-repeater functionality if { $Priv(repeated) == 0 } { uplevel #0 [list $w invoke] } } } } } ################## # Shared routines ################## # ::tk::ButtonInvoke -- # 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 ::tk::ButtonInvoke w { if {[winfo exists $w] && [$w cget -state] ne "disabled"} { set oldRelief [$w cget -relief] set oldState [$w cget -state] $w configure -state active -relief sunken after 100 [list ::tk::ButtonInvokeEnd $w $oldState $oldRelief] } } # ::tk::ButtonInvokeEnd -- # The procedure below is called after a button is invoked through # the keyboard. It simulate a release of the button via the mouse. # # Arguments: # w - The name of the widget. # oldState - Old state to be set back. # oldRelief - Old relief to be set back. proc ::tk::ButtonInvokeEnd {w oldState oldRelief} { if {[winfo exists $w]} { $w configure -state $oldState -relief $oldRelief uplevel #0 [list $w invoke] } } # ::tk::ButtonAutoInvoke -- # # Invoke an auto-repeating button, and set it up to continue to repeat. # # Arguments: # w button to invoke. # # Results: # None. # # Side effects: # May create an after event to call ::tk::ButtonAutoInvoke. proc ::tk::ButtonAutoInvoke {w} { variable ::tk::Priv after cancel $Priv(afterId) set delay [$w cget -repeatinterval] if {$Priv(window) eq $w} { incr Priv(repeated) uplevel #0 [list $w invoke] } if {$delay > 0} { set Priv(afterId) [after $delay [list tk::ButtonAutoInvoke $w]] } } # ::tk::CheckRadioInvoke -- # 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 ::tk::CheckRadioInvoke {w {cmd invoke}} { if {[$w cget -state] ne "disabled"} { uplevel #0 [list $w $cmd] } } # Special versions of the handlers for checkbuttons on Unix that do the magic # to make things work right when the checkbutton indicator is hidden; # radiobuttons don't need this complexity. # ::tk::CheckInvoke -- # The procedure below invokes the checkbutton, like ButtonInvoke, but handles # what to do when the checkbutton indicator is missing. Only used on Unix. # # Arguments: # w - The name of the widget. proc ::tk::CheckInvoke {w} { variable ::tk::Priv if {[$w cget -state] ne "disabled"} { # Additional logic to switch the "selected" colors around if necessary # (when we're indicator-less). if {![$w cget -indicatoron] && [info exist Priv($w,selectcolor)]} { if {[$w cget -selectcolor] eq $Priv($w,aselectcolor)} { $w configure -selectcolor $Priv($w,selectcolor) } else { $w configure -selectcolor $Priv($w,aselectcolor) } } uplevel #0 [list $w invoke] } } # ::tk::CheckEnter -- # The procedure below enters the checkbutton, like ButtonEnter, but handles # what to do when the checkbutton indicator is missing. Only used on Unix. # # Arguments: # w - The name of the widget. proc ::tk::CheckEnter {w} { variable ::tk::Priv if {[$w cget -state] ne "disabled"} { # On unix the state is active just with mouse-over $w configure -state active # If the mouse button is down, set the relief to sunken on entry. # Overwise, if there's an -overrelief value, set the relief to that. set Priv($w,relief) [$w cget -relief] if {$Priv(buttonWindow) eq $w} { $w configure -relief sunken set Priv($w,prelief) sunken } elseif {[set over [$w cget -overrelief]] ne ""} { $w configure -relief $over set Priv($w,prelief) $over } # Compute what the "selected and active" color should be. if {![$w cget -indicatoron] && [$w cget -selectcolor] ne ""} { set Priv($w,selectcolor) [$w cget -selectcolor] lassign [winfo rgb $w [$w cget -selectcolor]] r1 g1 b1 lassign [winfo rgb $w [$w cget -activebackground]] r2 g2 b2 set Priv($w,aselectcolor) \ [format "#%04x%04x%04x" [expr {($r1+$r2)/2}] \ [expr {($g1+$g2)/2}] [expr {($b1+$b2)/2}]] # use uplevel to work with other var resolvers if {[uplevel #0 [list set [$w cget -variable]]] eq [$w cget -onvalue]} { $w configure -selectcolor $Priv($w,aselectcolor) } } } set Priv(window) $w } # ::tk::CheckLeave -- # The procedure below leaves the checkbutton, like ButtonLeave, but handles # what to do when the checkbutton indicator is missing. Only used on Unix. # # Arguments: # w - The name of the widget. proc ::tk::CheckLeave {w} { variable ::tk::Priv if {[$w cget -state] ne "disabled"} { $w configure -state normal } # Restore the original button "selected" color; assume that the user # wasn't monkeying around with things too much. if {![$w cget -indicatoron] && [info exist Priv($w,selectcolor)]} { $w configure -selectcolor $Priv($w,selectcolor) } unset -nocomplain Priv($w,selectcolor) Priv($w,aselectcolor) # Restore the original button relief if it was changed by Tk. That is # signaled by the existence of Priv($w,prelief). if {[info exists Priv($w,relief)]} { if {[info exists Priv($w,prelief)] && \ $Priv($w,prelief) eq [$w cget -relief]} { $w configure -relief $Priv($w,relief) } unset -nocomplain Priv($w,relief) Priv($w,prelief) } set Priv(window) "" } return # Local Variables: # mode: tcl # fill-column: 78 # End: tk8.6.8/library/scrlbar.tcl0000644003604700454610000003071413212005724014272 0ustar dgp771div# scrlbar.tcl -- # # This file defines the default bindings for Tk scrollbar widgets. # It also provides procedures that help in implementing the bindings. # # 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 {[tk windowingsystem] eq "x11" || [tk windowingsystem] eq "aqua"} { bind Scrollbar { if {$tk_strictMotif} { set tk::Priv(activeBg) [%W cget -activebackground] %W configure -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 tk::Priv(activeBg)]} { %W configure -activebackground $tk::Priv(activeBg) } %W activate {} } bind Scrollbar <1> { tk::ScrollButtonDown %W %x %y } bind Scrollbar { tk::ScrollDrag %W %x %y } bind Scrollbar { tk::ScrollDrag %W %x %y } bind Scrollbar { tk::ScrollButtonUp %W %x %y } bind Scrollbar { # Prevents binding from being invoked. } bind Scrollbar { # Prevents binding from being invoked. } bind Scrollbar <2> { tk::ScrollButton2Down %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 { tk::ScrollDrag %W %x %y } bind Scrollbar { tk::ScrollButtonUp %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 { tk::ScrollTopBottom %W %x %y } bind Scrollbar { tk::ScrollTopBottom %W %x %y } bind Scrollbar <> { tk::ScrollByUnits %W v -1 } bind Scrollbar <> { tk::ScrollByUnits %W v 1 } bind Scrollbar <> { tk::ScrollByPages %W v -1 } bind Scrollbar <> { tk::ScrollByPages %W v 1 } bind Scrollbar <> { tk::ScrollByUnits %W h -1 } bind Scrollbar <> { tk::ScrollByUnits %W h 1 } bind Scrollbar <> { tk::ScrollByPages %W h -1 } bind Scrollbar <> { tk::ScrollByPages %W h 1 } bind Scrollbar { tk::ScrollByPages %W hv -1 } bind Scrollbar { tk::ScrollByPages %W hv 1 } bind Scrollbar <> { tk::ScrollToPos %W 0 } bind Scrollbar <> { tk::ScrollToPos %W 1 } } switch [tk windowingsystem] { "aqua" { bind Scrollbar { tk::ScrollByUnits %W v [expr {- (%D)}] } bind Scrollbar { tk::ScrollByUnits %W v [expr {-10 * (%D)}] } bind Scrollbar { tk::ScrollByUnits %W h [expr {- (%D)}] } bind Scrollbar { tk::ScrollByUnits %W h [expr {-10 * (%D)}] } } "win32" { bind Scrollbar { tk::ScrollByUnits %W v [expr {- (%D / 120) * 4}] } bind Scrollbar { tk::ScrollByUnits %W h [expr {- (%D / 120) * 4}] } } "x11" { bind Scrollbar { tk::ScrollByUnits %W v [expr {- (%D /120 ) * 4}] } bind Scrollbar { tk::ScrollByUnits %W h [expr {- (%D /120 ) * 4}] } bind Scrollbar <4> {tk::ScrollByUnits %W v -5} bind Scrollbar <5> {tk::ScrollByUnits %W v 5} bind Scrollbar {tk::ScrollByUnits %W h -5} bind Scrollbar {tk::ScrollByUnits %W h 5} } } # tk::ScrollButtonDown -- # 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 tk::ScrollButtonDown {w x y} { variable ::tk::Priv set Priv(relief) [$w cget -activerelief] $w configure -activerelief sunken set element [$w identify $x $y] if {$element eq "slider"} { ScrollStartDrag $w $x $y } else { ScrollSelect $w $element initial } } # ::tk::ScrollButtonUp -- # 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 ::tk::ScrollButtonUp {w x y} { variable ::tk::Priv tk::CancelRepeat if {[info exists Priv(relief)]} { # Avoid error due to spurious release events $w configure -activerelief $Priv(relief) ScrollEndDrag $w $x $y $w activate [$w identify $x $y] } } # ::tk::ScrollSelect -- # 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 ::tk::ScrollSelect {w element repeat} { variable ::tk::Priv if {![winfo exists $w]} return switch -- $element { "arrow1" {ScrollByUnits $w hv -1} "trough1" {ScrollByPages $w hv -1} "trough2" {ScrollByPages $w hv 1} "arrow2" {ScrollByUnits $w hv 1} default {return} } if {$repeat eq "again"} { set Priv(afterId) [after [$w cget -repeatinterval] \ [list tk::ScrollSelect $w $element again]] } elseif {$repeat eq "initial"} { set delay [$w cget -repeatdelay] if {$delay > 0} { set Priv(afterId) [after $delay \ [list tk::ScrollSelect $w $element again]] } } } # ::tk::ScrollStartDrag -- # 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 ::tk::ScrollStartDrag {w x y} { variable ::tk::Priv if {[$w cget -command] eq ""} { return } set Priv(pressX) $x set Priv(pressY) $y set Priv(initValues) [$w get] set iv0 [lindex $Priv(initValues) 0] if {[llength $Priv(initValues)] == 2} { set Priv(initPos) $iv0 } elseif {$iv0 == 0} { set Priv(initPos) 0.0 } else { set Priv(initPos) [expr {(double([lindex $Priv(initValues) 2])) \ / [lindex $Priv(initValues) 0]}] } } # ::tk::ScrollDrag -- # 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 ::tk::ScrollDrag {w x y} { variable ::tk::Priv if {$Priv(initPos) eq ""} { return } set delta [$w delta [expr {$x - $Priv(pressX)}] [expr {$y - $Priv(pressY)}]] if {[$w cget -jump]} { if {[llength $Priv(initValues)] == 2} { $w set [expr {[lindex $Priv(initValues) 0] + $delta}] \ [expr {[lindex $Priv(initValues) 1] + $delta}] } else { set delta [expr {round($delta * [lindex $Priv(initValues) 0])}] eval [list $w] set [lreplace $Priv(initValues) 2 3 \ [expr {[lindex $Priv(initValues) 2] + $delta}] \ [expr {[lindex $Priv(initValues) 3] + $delta}]] } } else { ScrollToPos $w [expr {$Priv(initPos) + $delta}] } } # ::tk::ScrollEndDrag -- # 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 ::tk::ScrollEndDrag {w x y} { variable ::tk::Priv if {$Priv(initPos) eq ""} { return } if {[$w cget -jump]} { set delta [$w delta [expr {$x - $Priv(pressX)}] \ [expr {$y - $Priv(pressY)}]] ScrollToPos $w [expr {$Priv(initPos) + $delta}] } set Priv(initPos) "" } # ::tk::ScrollByUnits -- # 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 ::tk::ScrollByUnits {w orient amount} { set cmd [$w cget -command] if {$cmd eq "" || ([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}] } } # ::tk::ScrollByPages -- # 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 ::tk::ScrollByPages {w orient amount} { set cmd [$w cget -command] if {$cmd eq "" || ([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)}] } } # ::tk::ScrollToPos -- # 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 ::tk::ScrollToPos {w pos} { set cmd [$w cget -command] if {$cmd eq ""} { return } set info [$w get] if {[llength $info] == 2} { uplevel #0 $cmd moveto $pos } else { uplevel #0 $cmd [expr {round([lindex $info 0]*$pos)}] } } # ::tk::ScrollTopBottom # 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 ::tk::ScrollTopBottom {w x y} { variable ::tk::Priv set element [$w identify $x $y] if {[string match *1 $element]} { ScrollToPos $w 0 } elseif {[string match *2 $element]} { ScrollToPos $w 1 } # Set Priv(relief), since it's needed by tk::ScrollButtonUp. set Priv(relief) [$w cget -activerelief] } # ::tk::ScrollButton2Down # 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 ::tk::ScrollButton2Down {w x y} { variable ::tk::Priv if {![winfo exists $w]} { return } set element [$w identify $x $y] if {[string match {arrow[12]} $element]} { ScrollButtonDown $w $x $y return } ScrollToPos $w [$w fraction $x $y] set Priv(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 if {[winfo exists $w]} { $w configure -activerelief sunken $w activate slider ScrollStartDrag $w $x $y } } tk8.6.8/library/xmfbox.tcl0000644003604700454610000006273313212005724014153 0ustar dgp771div# xmfbox.tcl -- # # Implements the "Motif" style file selection dialog for the # Unix platform. This implementation is used only if the # "::tk_strictMotif" flag is set. # # Copyright (c) 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. namespace eval ::tk::dialog {} namespace eval ::tk::dialog::file {} # ::tk::MotifFDialog -- # # Implements a file dialog similar to the standard Motif file # selection box. # # Arguments: # type "open" or "save" # args Options parsed by the procedure. # # Results: # When -multiple is set to 0, this returns the absolute pathname # of the selected file. (NOTE: This is not the same as a single # element list.) # # When -multiple is set to > 0, this returns a Tcl list of absolute # pathnames. The argument for -multiple is ignored, but for consistency # with Windows it defines the maximum amount of memory to allocate for # the returned filenames. proc ::tk::MotifFDialog {type args} { variable ::tk::Priv set dataName __tk_filedialog upvar ::tk::dialog::file::$dataName data set w [MotifFDialog_Create $dataName $type $args] # Set a grab and claim the focus too. ::tk::SetFocusGrab $w $data(sEnt) $data(sEnt) selection range 0 end # 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. vwait ::tk::Priv(selectFilePath) set result $Priv(selectFilePath) ::tk::RestoreFocusGrab $w $data(sEnt) withdraw return $result } # ::tk::MotifFDialog_Create -- # # Creates the Motif file dialog (if it doesn't exist yet) and # initialize the internal data structure associated with the # dialog. # # This procedure is used by ::tk::MotifFDialog to create the # dialog. It's also used by the test suite to test the Motif # file dialog implementation. User code shouldn't call this # procedure directly. # # Arguments: # dataName Name of the global "data" array for the file dialog. # type "Save" or "Open" # argList Options parsed by the procedure. # # Results: # Pathname of the file dialog. proc ::tk::MotifFDialog_Create {dataName type argList} { upvar ::tk::dialog::file::$dataName data MotifFDialog_Config $dataName $type $argList if {$data(-parent) eq "."} { set w .$dataName } else { set w $data(-parent).$dataName } # (re)create the dialog box if necessary # if {![winfo exists $w]} { MotifFDialog_BuildUI $w } elseif {[winfo class $w] ne "TkMotifFDialog"} { destroy $w MotifFDialog_BuildUI $w } else { set data(fEnt) $w.top.f1.ent set data(dList) $w.top.f2.a.l set data(fList) $w.top.f2.b.l set data(sEnt) $w.top.f3.ent set data(okBtn) $w.bot.ok set data(filterBtn) $w.bot.filter set data(cancelBtn) $w.bot.cancel } MotifFDialog_SetListMode $w # 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 $data(-parent)]] } { wm transient $w $data(-parent) } MotifFDialog_FileTypes $w MotifFDialog_Update $w # 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 (Motif style) and de-iconify it. ::tk::PlaceWindow $w wm title $w $data(-title) return $w } # ::tk::MotifFDialog_FileTypes -- # # Checks the -filetypes option. If present this adds a list of radio- # buttons to pick the file types from. # # Arguments: # w Pathname of the tk_get*File dialogue. # # Results: # none proc ::tk::MotifFDialog_FileTypes {w} { upvar ::tk::dialog::file::[winfo name $w] data set f $w.top.f3.types destroy $f # No file types: use "*" as the filter and display no radio-buttons if {$data(-filetypes) eq ""} { set data(filter) * return } # The filetypes radiobuttons # set data(fileType) $data(-defaulttype) # Default type to first entry set initialTypeName [lindex $data(origfiletypes) 0 0] if {$data(-typevariable) ne ""} { upvar #0 $data(-typevariable) typeVariable if {[info exists typeVariable]} { set initialTypeName $typeVariable } } set ix 0 set data(fileType) 0 foreach fltr $data(origfiletypes) { set fname [lindex $fltr 0] if {[string first $initialTypeName $fname] == 0} { set data(fileType) $ix break } incr ix } MotifFDialog_SetFilter $w [lindex $data(-filetypes) $data(fileType)] #don't produce radiobuttons for only one filetype if {[llength $data(-filetypes)] == 1} { return } frame $f set cnt 0 if {$data(-filetypes) ne {}} { foreach type $data(-filetypes) { set title [lindex $type 0] set filter [lindex $type 1] radiobutton $f.b$cnt \ -text $title \ -variable ::tk::dialog::file::[winfo name $w](fileType) \ -value $cnt \ -command [list tk::MotifFDialog_SetFilter $w $type] pack $f.b$cnt -side left incr cnt } } $f.b$data(fileType) invoke pack $f -side bottom -fill both return } # This proc gets called whenever data(filter) is set # proc ::tk::MotifFDialog_SetFilter {w type} { upvar ::tk::dialog::file::[winfo name $w] data variable ::tk::Priv set data(filter) [lindex $type 1] set Priv(selectFileType) [lindex [lindex $type 0] 0] MotifFDialog_Update $w } # ::tk::MotifFDialog_Config -- # # Iterates over the optional arguments to determine the option # values for the Motif file dialog; gives default values to # unspecified options. # # Arguments: # dataName The name of the global variable in which # data for the file dialog is stored. # type "Save" or "Open" # argList Options parsed by the procedure. proc ::tk::MotifFDialog_Config {dataName type argList} { upvar ::tk::dialog::file::$dataName data set data(type) $type # 1: the configuration specs # set specs { {-defaultextension "" "" ""} {-filetypes "" "" ""} {-initialdir "" "" ""} {-initialfile "" "" ""} {-parent "" "" "."} {-title "" "" ""} {-typevariable "" "" ""} } if {$type eq "open"} { lappend specs {-multiple "" "" "0"} } if {$type eq "save"} { lappend specs {-confirmoverwrite "" "" "1"} } set data(-multiple) 0 set data(-confirmoverwrite) 1 # 2: default values depending on the type of the dialog # if {![info exists data(selectPath)]} { # first time the dialog has been popped up set data(selectPath) [pwd] set data(selectFile) "" } # 3: parse the arguments # tclParseConfigSpec ::tk::dialog::file::$dataName $specs "" $argList if {$data(-title) eq ""} { if {$type eq "open"} { if {$data(-multiple) != 0} { set data(-title) "[mc {Open Multiple Files}]" } else { set data(-title) [mc "Open"] } } else { set data(-title) [mc "Save As"] } } # 4: set the default directory and selection according to the -initial # settings # if {$data(-initialdir) ne ""} { if {[file isdirectory $data(-initialdir)]} { set data(selectPath) [lindex [glob $data(-initialdir)] 0] } else { set data(selectPath) [pwd] } # Convert the initialdir to an absolute path name. set old [pwd] cd $data(selectPath) set data(selectPath) [pwd] cd $old } set data(selectFile) $data(-initialfile) # 5. Parse the -filetypes option. It is not used by the motif # file dialog, but we check for validity of the value to make sure # the application code also runs fine with the TK file dialog. # set data(origfiletypes) $data(-filetypes) set data(-filetypes) [::tk::FDGetFileTypes $data(-filetypes)] if {![info exists data(filter)]} { set data(filter) * } if {![winfo exists $data(-parent)]} { return -code error -errorcode [list TK LOOKUP WINDOW $data(-parent)] \ "bad window path name \"$data(-parent)\"" } } # ::tk::MotifFDialog_BuildUI -- # # Builds the UI components of the Motif file dialog. # # Arguments: # w Pathname of the dialog to build. # # Results: # None. proc ::tk::MotifFDialog_BuildUI {w} { set dataName [lindex [split $w .] end] upvar ::tk::dialog::file::$dataName data # Create the dialog toplevel and internal frames. # toplevel $w -class TkMotifFDialog set top [frame $w.top -relief raised -bd 1] set bot [frame $w.bot -relief raised -bd 1] pack $w.bot -side bottom -fill x pack $w.top -side top -expand yes -fill both set f1 [frame $top.f1] set f2 [frame $top.f2] set f3 [frame $top.f3] pack $f1 -side top -fill x pack $f3 -side bottom -fill x pack $f2 -expand yes -fill both set f2a [frame $f2.a] set f2b [frame $f2.b] grid $f2a -row 0 -column 0 -rowspan 1 -columnspan 1 -padx 4 -pady 4 \ -sticky news grid $f2b -row 0 -column 1 -rowspan 1 -columnspan 1 -padx 4 -pady 4 \ -sticky news grid rowconfigure $f2 0 -minsize 0 -weight 1 grid columnconfigure $f2 0 -minsize 0 -weight 1 grid columnconfigure $f2 1 -minsize 150 -weight 2 # The Filter box # bind [::tk::AmpWidget label $f1.lab -text [mc "Fil&ter:"] -anchor w] \ <> [list focus $f1.ent] entry $f1.ent pack $f1.lab -side top -fill x -padx 6 -pady 4 pack $f1.ent -side top -fill x -padx 4 -pady 0 set data(fEnt) $f1.ent # The file and directory lists # set data(dList) [MotifFDialog_MakeSList $w $f2a \ [mc "&Directory:"] DList] set data(fList) [MotifFDialog_MakeSList $w $f2b \ [mc "Fi&les:"] FList] # The Selection box # bind [::tk::AmpWidget label $f3.lab -text [mc "&Selection:"] -anchor w] \ <> [list focus $f3.ent] entry $f3.ent pack $f3.lab -side top -fill x -padx 6 -pady 0 pack $f3.ent -side top -fill x -padx 4 -pady 4 set data(sEnt) $f3.ent # The buttons # set maxWidth [::tk::mcmaxamp &OK &Filter &Cancel] set maxWidth [expr {$maxWidth<6?6:$maxWidth}] set data(okBtn) [::tk::AmpWidget button $bot.ok -text [mc "&OK"] \ -width $maxWidth \ -command [list tk::MotifFDialog_OkCmd $w]] set data(filterBtn) [::tk::AmpWidget button $bot.filter -text [mc "&Filter"] \ -width $maxWidth \ -command [list tk::MotifFDialog_FilterCmd $w]] set data(cancelBtn) [::tk::AmpWidget button $bot.cancel -text [mc "&Cancel"] \ -width $maxWidth \ -command [list tk::MotifFDialog_CancelCmd $w]] pack $bot.ok $bot.filter $bot.cancel -padx 10 -pady 10 -expand yes \ -side left # Create the bindings: # bind $w [list ::tk::AltKeyInDialog $w %A] bind $data(fEnt) [list tk::MotifFDialog_ActivateFEnt $w] bind $data(sEnt) [list tk::MotifFDialog_ActivateSEnt $w] bind $w [list tk::MotifFDialog_CancelCmd $w] bind $w.bot {set ::tk::Priv(selectFilePath) {}} wm protocol $w WM_DELETE_WINDOW [list tk::MotifFDialog_CancelCmd $w] } proc ::tk::MotifFDialog_SetListMode {w} { upvar ::tk::dialog::file::[winfo name $w] data if {$data(-multiple) != 0} { set selectmode extended } else { set selectmode browse } set f $w.top.f2.b $f.l configure -selectmode $selectmode } # ::tk::MotifFDialog_MakeSList -- # # Create a scrolled-listbox and set the keyboard accelerator # bindings so that the list selection follows what the user # types. # # Arguments: # w Pathname of the dialog box. # f Frame widget inside which to create the scrolled # listbox. This frame widget already exists. # label The string to display on top of the listbox. # under Sets the -under option of the label. # cmdPrefix Specifies procedures to call when the listbox is # browsed or activated. proc ::tk::MotifFDialog_MakeSList {w f label cmdPrefix} { bind [::tk::AmpWidget label $f.lab -text $label -anchor w] \ <> [list focus $f.l] listbox $f.l -width 12 -height 5 -exportselection 0\ -xscrollcommand [list $f.h set] -yscrollcommand [list $f.v set] scrollbar $f.v -orient vertical -takefocus 0 -command [list $f.l yview] scrollbar $f.h -orient horizontal -takefocus 0 -command [list $f.l xview] grid $f.lab -row 0 -column 0 -sticky news -rowspan 1 -columnspan 2 \ -padx 2 -pady 2 grid $f.l -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news grid $f.v -row 1 -column 1 -rowspan 1 -columnspan 1 -sticky news grid $f.h -row 2 -column 0 -rowspan 1 -columnspan 1 -sticky news grid rowconfigure $f 0 -weight 0 -minsize 0 grid rowconfigure $f 1 -weight 1 -minsize 0 grid columnconfigure $f 0 -weight 1 -minsize 0 # bindings for the listboxes # set list $f.l bind $list <> [list tk::MotifFDialog_Browse$cmdPrefix $w] bind $list \ [list tk::MotifFDialog_Activate$cmdPrefix $w] bind $list "tk::MotifFDialog_Browse$cmdPrefix [list $w]; \ tk::MotifFDialog_Activate$cmdPrefix [list $w]" bindtags $list [list Listbox $list [winfo toplevel $list] all] ListBoxKeyAccel_Set $list return $f.l } # ::tk::MotifFDialog_InterpFilter -- # # Interpret the string in the filter entry into two components: # the directory and the pattern. If the string is a relative # pathname, give a warning to the user and restore the pattern # to original. # # Arguments: # w pathname of the dialog box. # # Results: # A list of two elements. The first element is the directory # specified # by the filter. The second element is the filter # pattern itself. proc ::tk::MotifFDialog_InterpFilter {w} { upvar ::tk::dialog::file::[winfo name $w] data set text [string trim [$data(fEnt) get]] # Perform tilde substitution # set badTilde 0 if {[string index $text 0] eq "~"} { set list [file split $text] set tilde [lindex $list 0] if {[catch {set tilde [glob $tilde]}]} { set badTilde 1 } else { set text [eval file join [concat $tilde [lrange $list 1 end]]] } } # If the string is a relative pathname, combine it # with the current selectPath. set relative 0 if {[file pathtype $text] eq "relative"} { set relative 1 } elseif {$badTilde} { set relative 1 } if {$relative} { tk_messageBox -icon warning -type ok \ -message "\"$text\" must be an absolute pathname" $data(fEnt) delete 0 end $data(fEnt) insert 0 [::tk::dialog::file::JoinFile $data(selectPath) \ $data(filter)] return [list $data(selectPath) $data(filter)] } set resolved [::tk::dialog::file::JoinFile [file dirname $text] [file tail $text]] if {[file isdirectory $resolved]} { set dir $resolved set fil $data(filter) } else { set dir [file dirname $resolved] set fil [file tail $resolved] } return [list $dir $fil] } # ::tk::MotifFDialog_Update # # Load the files and synchronize the "filter" and "selection" fields # boxes. # # Arguments: # w pathname of the dialog box. # # Results: # None. proc ::tk::MotifFDialog_Update {w} { upvar ::tk::dialog::file::[winfo name $w] data $data(fEnt) delete 0 end $data(fEnt) insert 0 \ [::tk::dialog::file::JoinFile $data(selectPath) $data(filter)] $data(sEnt) delete 0 end $data(sEnt) insert 0 [::tk::dialog::file::JoinFile $data(selectPath) \ $data(selectFile)] MotifFDialog_LoadFiles $w } # ::tk::MotifFDialog_LoadFiles -- # # Loads the files and directories into the two listboxes according # to the filter setting. # # Arguments: # w pathname of the dialog box. # # Results: # None. proc ::tk::MotifFDialog_LoadFiles {w} { upvar ::tk::dialog::file::[winfo name $w] data $data(dList) delete 0 end $data(fList) delete 0 end set appPWD [pwd] if {[catch {cd $data(selectPath)}]} { cd $appPWD $data(dList) insert end ".." return } # Make the dir and file lists # # For speed we only have one glob, which reduces the file system # calls (good for slow NFS networks). # # We also do two smaller sorts (files + dirs) instead of one large sort, # which gives a small speed increase. # set top 0 set dlist "" set flist "" foreach f [glob -nocomplain .* *] { if {[file isdir ./$f]} { lappend dlist $f } else { foreach pat $data(filter) { if {[string match $pat $f]} { if {[string match .* $f]} { incr top } lappend flist $f break } } } } eval [list $data(dList) insert end] [lsort -dictionary $dlist] eval [list $data(fList) insert end] [lsort -dictionary $flist] # The user probably doesn't want to see the . files. We adjust the view # so that the listbox displays all the non-dot files $data(fList) yview $top cd $appPWD } # ::tk::MotifFDialog_BrowseDList -- # # This procedure is called when the directory list is browsed # (clicked-over) by the user. # # Arguments: # w The pathname of the dialog box. # # Results: # None. proc ::tk::MotifFDialog_BrowseDList {w} { upvar ::tk::dialog::file::[winfo name $w] data focus $data(dList) if {[$data(dList) curselection] eq ""} { return } set subdir [$data(dList) get [$data(dList) curselection]] if {$subdir eq ""} { return } $data(fList) selection clear 0 end set list [MotifFDialog_InterpFilter $w] set data(filter) [lindex $list 1] switch -- $subdir { . { set newSpec [::tk::dialog::file::JoinFile $data(selectPath) $data(filter)] } .. { set newSpec [::tk::dialog::file::JoinFile [file dirname $data(selectPath)] \ $data(filter)] } default { set newSpec [::tk::dialog::file::JoinFile [::tk::dialog::file::JoinFile \ $data(selectPath) $subdir] $data(filter)] } } $data(fEnt) delete 0 end $data(fEnt) insert 0 $newSpec } # ::tk::MotifFDialog_ActivateDList -- # # This procedure is called when the directory list is activated # (double-clicked) by the user. # # Arguments: # w The pathname of the dialog box. # # Results: # None. proc ::tk::MotifFDialog_ActivateDList {w} { upvar ::tk::dialog::file::[winfo name $w] data if {[$data(dList) curselection] eq ""} { return } set subdir [$data(dList) get [$data(dList) curselection]] if {$subdir eq ""} { return } $data(fList) selection clear 0 end switch -- $subdir { . { set newDir $data(selectPath) } .. { set newDir [file dirname $data(selectPath)] } default { set newDir [::tk::dialog::file::JoinFile $data(selectPath) $subdir] } } set data(selectPath) $newDir MotifFDialog_Update $w if {$subdir ne ".."} { $data(dList) selection set 0 $data(dList) activate 0 } else { $data(dList) selection set 1 $data(dList) activate 1 } } # ::tk::MotifFDialog_BrowseFList -- # # This procedure is called when the file list is browsed # (clicked-over) by the user. # # Arguments: # w The pathname of the dialog box. # # Results: # None. proc ::tk::MotifFDialog_BrowseFList {w} { upvar ::tk::dialog::file::[winfo name $w] data focus $data(fList) set data(selectFile) "" foreach item [$data(fList) curselection] { lappend data(selectFile) [$data(fList) get $item] } if {[llength $data(selectFile)] == 0} { return } $data(dList) selection clear 0 end $data(fEnt) delete 0 end $data(fEnt) insert 0 [::tk::dialog::file::JoinFile $data(selectPath) \ $data(filter)] $data(fEnt) xview end # if it's a multiple selection box, just put in the filenames # otherwise put in the full path as usual $data(sEnt) delete 0 end if {$data(-multiple) != 0} { $data(sEnt) insert 0 $data(selectFile) } else { $data(sEnt) insert 0 [::tk::dialog::file::JoinFile $data(selectPath) \ [lindex $data(selectFile) 0]] } $data(sEnt) xview end } # ::tk::MotifFDialog_ActivateFList -- # # This procedure is called when the file list is activated # (double-clicked) by the user. # # Arguments: # w The pathname of the dialog box. # # Results: # None. proc ::tk::MotifFDialog_ActivateFList {w} { upvar ::tk::dialog::file::[winfo name $w] data if {[$data(fList) curselection] eq ""} { return } set data(selectFile) [$data(fList) get [$data(fList) curselection]] if {$data(selectFile) eq ""} { return } else { MotifFDialog_ActivateSEnt $w } } # ::tk::MotifFDialog_ActivateFEnt -- # # This procedure is called when the user presses Return inside # the "filter" entry. It updates the dialog according to the # text inside the filter entry. # # Arguments: # w The pathname of the dialog box. # # Results: # None. proc ::tk::MotifFDialog_ActivateFEnt {w} { upvar ::tk::dialog::file::[winfo name $w] data set list [MotifFDialog_InterpFilter $w] set data(selectPath) [lindex $list 0] set data(filter) [lindex $list 1] MotifFDialog_Update $w } # ::tk::MotifFDialog_ActivateSEnt -- # # This procedure is called when the user presses Return inside # the "selection" entry. It sets the ::tk::Priv(selectFilePath) # variable so that the vwait loop in tk::MotifFDialog will be # terminated. # # Arguments: # w The pathname of the dialog box. # # Results: # None. proc ::tk::MotifFDialog_ActivateSEnt {w} { variable ::tk::Priv upvar ::tk::dialog::file::[winfo name $w] data set selectFilePath [string trim [$data(sEnt) get]] if {$selectFilePath eq ""} { MotifFDialog_FilterCmd $w return } if {$data(-multiple) == 0} { set selectFilePath [list $selectFilePath] } if {[file isdirectory [lindex $selectFilePath 0]]} { set data(selectPath) [lindex [glob $selectFilePath] 0] set data(selectFile) "" MotifFDialog_Update $w return } set newFileList "" foreach item $selectFilePath { if {[file pathtype $item] ne "absolute"} { set item [file join $data(selectPath) $item] } elseif {![file exists [file dirname $item]]} { tk_messageBox -icon warning -type ok \ -message [mc {Directory "%1$s" does not exist.} \ [file dirname $item]] return } if {![file exists $item]} { if {$data(type) eq "open"} { tk_messageBox -icon warning -type ok \ -message [mc {File "%1$s" does not exist.} $item] return } } elseif {$data(type) eq "save" && $data(-confirmoverwrite)} { set message [format %s%s \ [mc "File \"%1\$s\" already exists.\n\n" $selectFilePath] \ [mc {Replace existing file?}]] set answer [tk_messageBox -icon warning -type yesno \ -message $message] if {$answer eq "no"} { return } } lappend newFileList $item } # Return selected filter if {[info exists data(-typevariable)] && $data(-typevariable) ne "" && [info exists data(-filetypes)] && $data(-filetypes) ne ""} { upvar #0 $data(-typevariable) typeVariable set typeVariable [lindex $data(origfiletypes) $data(fileType) 0] } if {$data(-multiple) != 0} { set Priv(selectFilePath) $newFileList } else { set Priv(selectFilePath) [lindex $newFileList 0] } # Set selectFile and selectPath to first item in list set Priv(selectFile) [file tail [lindex $newFileList 0]] set Priv(selectPath) [file dirname [lindex $newFileList 0]] } proc ::tk::MotifFDialog_OkCmd {w} { upvar ::tk::dialog::file::[winfo name $w] data MotifFDialog_ActivateSEnt $w } proc ::tk::MotifFDialog_FilterCmd {w} { upvar ::tk::dialog::file::[winfo name $w] data MotifFDialog_ActivateFEnt $w } proc ::tk::MotifFDialog_CancelCmd {w} { variable ::tk::Priv set Priv(selectFilePath) "" set Priv(selectFile) "" set Priv(selectPath) "" } proc ::tk::ListBoxKeyAccel_Set {w} { bind Listbox "" bind $w [list tk::ListBoxKeyAccel_Unset $w] bind $w [list tk::ListBoxKeyAccel_Key $w %A] } proc ::tk::ListBoxKeyAccel_Unset {w} { variable ::tk::Priv catch {after cancel $Priv(lbAccel,$w,afterId)} unset -nocomplain Priv(lbAccel,$w) Priv(lbAccel,$w,afterId) } # ::tk::ListBoxKeyAccel_Key-- # # This procedure maintains a list of recently entered keystrokes # over a listbox widget. It arranges an idle event to move the # selection of the listbox to the entry that begins with the # keystrokes. # # Arguments: # w The pathname of the listbox. # key The key which the user just pressed. # # Results: # None. proc ::tk::ListBoxKeyAccel_Key {w key} { variable ::tk::Priv if { $key eq "" } { return } append Priv(lbAccel,$w) $key ListBoxKeyAccel_Goto $w $Priv(lbAccel,$w) catch { after cancel $Priv(lbAccel,$w,afterId) } set Priv(lbAccel,$w,afterId) [after 500 \ [list tk::ListBoxKeyAccel_Reset $w]] } proc ::tk::ListBoxKeyAccel_Goto {w string} { variable ::tk::Priv set string [string tolower $string] set end [$w index end] set theIndex -1 for {set i 0} {$i < $end} {incr i} { set item [string tolower [$w get $i]] if {[string compare $string $item] >= 0} { set theIndex $i } if {[string compare $string $item] <= 0} { set theIndex $i break } } if {$theIndex >= 0} { $w selection clear 0 end $w selection set $theIndex $theIndex $w activate $theIndex $w see $theIndex event generate $w <> } } proc ::tk::ListBoxKeyAccel_Reset {w} { variable ::tk::Priv unset -nocomplain Priv(lbAccel,$w) } proc ::tk_getFileType {} { variable ::tk::Priv return $Priv(selectFileType) } tk8.6.8/library/license.terms0000644003604700454610000000433313212005724014632 0ustar dgp771divThis software is copyrighted by the Regents of the University of California, Sun Microsystems, Inc., Scriptics Corporation, ActiveState Corporation, Apple Inc. and other parties. The following terms apply to all files associated with the software unless explicitly disclaimed in individual files. The authors hereby grant permission to use, copy, modify, distribute, and license this software and its documentation for any purpose, provided that existing copyright notices are retained in all copies and that this notice is included verbatim in any distributions. No written agreement, license, or royalty fee is required for any of the authorized uses. Modifications to this software may be copyrighted by their authors and need not follow the licensing terms described here, provided that the new terms are clearly indicated on the first page of each file where they apply. IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. GOVERNMENT USE: If you are acquiring this software on behalf of the U.S. government, the Government shall have only "Restricted Rights" in the software and related documentation as defined in the Federal Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you are acquiring the software on behalf of the Department of Defense, the software shall be classified as "Commercial Computer Software" and the Government shall have only "Restricted Rights" as defined in Clause 252.227-7013 (b) (3) of DFARs. Notwithstanding the foregoing, the authors grant the U.S. Government and others acting in its behalf permission to use and distribute the software in accordance with the terms specified in this license. tk8.6.8/library/iconlist.tcl0000644003604700454610000003715213212005724014471 0ustar dgp771div# iconlist.tcl # # Implements the icon-list megawidget used in the "Tk" standard file # selection dialog boxes. # # Copyright (c) 1994-1998 Sun Microsystems, Inc. # Copyright (c) 2009 Donal K. Fellows # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # # API Summary: # tk::IconList ?