/lib/toolbar.tcl
TCL | 450 lines | 315 code | 71 blank | 64 comment | 43 complexity | 4df32325a7e7e508aefe4680be55ff57 MD5 | raw file
- # -------------------------------------------------------------
- # toolbar.tcl
- # This file is part of the tkBuilder distribution
- # Copyright (C) 1999, 2000 Frank Schnekenburger
- # Distributed under the terms of the GNU General Public License
- #
- # Modified by andrasy on 10/22/06 for :
- # - tcl 8.4.13
- # - BWidget 1.7
- # - msgcat calls added for translation
- # - combobox from Bryan Oakley replaced by ::ComboBox of BWidget
- # -------------------------------------------------------------
- #
- # This file was built using tkBuilder
- #
- namespace eval Toolbar {
- variable _height_ 20
- variable _width_ 23
- # constrained dimensions of buttons
-
- variable _relation_ {}
- # current relation used for insertion; one of SIBLING or CHILD
-
- variable _butRelation_
- # array used for names of sibling and child buttons
- # indexed on SIBLING and CHILD
-
- variable _fraRelation_
- # array used for names of frames containing sibling and child buttons
- # indexed on SIBLING and CHILD
-
- variable _frame_
- # array used to register name of frames used for widgets, canvas objects, and menu entries
- # indexed on widget, canvas, menu, special
-
- variable _currentToolbarFrame_ widget
- # indicates which of 'widget' or 'special' is currently displayed
- # in the widget toolbar, to control toggling among widgets and special
- # objects
-
- variable _frameMainToolbar_
- # main frame to hold main toolbar
-
- variable _frameToolbar_
- # main frame to hold entire widget toolbar
-
- variable _frameMainPane_
- # frame above which the main toolbar is packed in the display
-
- variable _toolbar_ widget
- # current toolbar type: one of widget, special, canvas or menu
-
- variable _toolTip_ {} ; # name of toplevel window used for tool tip
- variable _toolTipActive_ 0 ; # 1 if delay not required before displaying tooltip
- variable _afterID_ ; # id of pending 'after' command for tool tip
-
- variable _background_
- # background colour needed for relation buttons
-
- proc CreateMainToolbar { fraMainToolbar fraMainPane } {
- variable _frameMainToolbar_ $fraMainToolbar
- variable _frameMainPane_ $fraMainPane ; # remember frame to pack before
- variable _height_
- variable _width_
- variable _butGeometry_
-
- # ensure tool tip is deactivated after leaving the toolbar, to
- # force the delay next time we enter
- bind $_frameMainToolbar_ <Leave> "set Toolbar::_toolTipActive_ 0"
-
- # bindings on icon button binding tag
- bind IconButton <ButtonPress-1> "focus %W; Toolbar::HideToolTip"
- bind IconButton <Leave> "%W configure -relief flat; Toolbar::HideToolTip"
-
- # make frame for separator line
- set fraSeparator [frame $fraMainToolbar.fraSeparator -bd 3 -height 2 -relief sunken]
- pack $fraSeparator -side top -anchor nw -fill x -pady 1
-
- # make frame to hold icons
- set fraIcons [frame $fraMainToolbar.fraIcons -bd 0]
- pack $fraIcons -side top -anchor nw
-
- foreach { icon tooltip command } {
- open "[mc {Open Project}]" File::OpenFile
- save "[mc {Save Project}]" File::SaveFile
- saveTcl "[mc {Save Tcl Files}]" Project::SaveProjectTclFiles
- separator {} {} } {
-
- if { $icon == "separator" } {
- AddSeparator $fraIcons left
- } else {
- AddIcon $fraIcons left $icon $tooltip $command
- }
- }
-
- foreach man {pack grid place} {
- # make confining frame for button
- set fraBut [frame $fraIcons.fra_$man -height $_height_ -width $_width_]
- pack $fraBut -side left
- pack propagate $fraBut 0
-
- set b [button $fraBut.button -image [Icon::GetIconImage $man] \
- -relief flat -bd 1 -takefocus 0]
- pack $b
-
- bind $b <ButtonPress-1> "Toolbar::HideToolTip
- Option::SetOption geometryManager $man
- Toolbar::UpdateGeometryManager"
- set _butGeometry_($man) $b
-
- }
- UpdateGeometryManager
-
- # 1.0.2a: 04/19/00: bug fix: added WidgetTree::CopyWidgetToSiblings and Descendants
- foreach { icon tooltip command } {
- separator {} {}
- duplicateWidget "[mc {Duplicate Widget}]" WidgetTree::DuplicateWidget
- duplicateBranch "[mc {Duplicate Branch}]" WidgetTree::DuplicateBranch
- copyToSiblings "[mc {Copy To Siblings}]" WidgetTree::CopyWidgetToSiblings
- copyToDescendants "[mc {Copy To Descendants}]" WidgetTree::CopyWidgetToDescendants
- deleteWidget "[mc {Delete Widget}]" WidgetTree::DeleteWidgetNode
- deleteBranch "[mc {Delete Branch}]" WidgetTree::DeleteWidgetBranch
- separator {} {}
- runProject "[mc {Run Project}]" "Build::BuildBranch RUN_PROJECT"
- runBranch "[mc {Run Branch}]" "Build::BuildBranch RUN_BRANCH"
- runLast "[mc {Run Last}]" "Build::BuildBranch RUN_LAST"
- stop "[mc {Stop}] " Build::StopApplication
- separator {} {}
- view "[mc {View Branch}]" "Build::BuildBranch VIEW_TCL" } {
-
- if { $icon == "separator" } {
- AddSeparator $fraIcons left
- } else {
- AddIcon $fraIcons left $icon $tooltip $command
- }
- }
-
-
- }
- proc ShowMainToolbar { } {
- variable _frameMainToolbar_
- variable _frameMainPane_
-
- if { [Option::GetOption mainToolbarShow] } {
- pack $_frameMainToolbar_ -side top -anchor nw -fill x -before $_frameMainPane_
- } else {
- pack forget $_frameMainToolbar_
- }
- }
- proc UpdateGeometryManager { } {
- variable _butGeometry_
-
- set geometryManager [Option::GetOption geometryManager]
- foreach { man tip } { pack Pack grid Grid place Place } {
- set b $_butGeometry_($man)
- if { $man == $geometryManager } {
- $_butGeometry_($man) configure -relief sunken
- bind $b <Enter> "Toolbar::ShowToolTip $tip \[winfo rootx %W] \[winfo rooty %W] "
- bind $b <Leave> "Toolbar::HideToolTip"
- } else {
- $_butGeometry_($man) configure -relief flat
- bind $b <Enter> "Toolbar::ShowToolTip $tip \[winfo rootx %W] \[winfo rooty %W]
- $_butGeometry_($man) configure -relief raised"
- bind $b <Leave> "Toolbar::HideToolTip
- $_butGeometry_($man) configure -relief flat"
- }
- }
-
- }
- proc CreateToolbar { fraToolbar fraTree } {
- variable _frameToolbar_ $fraToolbar
- variable _frameTree_ $fraTree ; # remember frame used to pack before
- variable _frame_
- variable _butRelation_
- variable _fraRelation_
- variable _height_
- variable _width_
- variable _background_
-
- # ensure tool tip is deactivated after leaving the toolbar, to
- # force the delay next time we enter
- bind $_frameToolbar_ <Leave> "set Toolbar::_toolTipActive_ 0"
-
- set _background_ [Utility::GetBackgroundColour]
- set _fraRelation_(SIBLING) [frame $fraToolbar.fraSibling -background red -height $_height_ -width $_width_]
- pack $fraToolbar.fraSibling -padx 1 -pady 1
- pack propagate $_fraRelation_(SIBLING) 0
-
- set _butRelation_(SIBLING) [button $fraToolbar.fraSibling.button -command {Toolbar::UpdateRelation SIBLING
- Toolbar::UpdateToolbar 0} -image "[Icon::GetIconImage sibling]" -takefocus 0]
- pack $fraToolbar.fraSibling.button -padx 1 -pady 1
- bind $fraToolbar.fraSibling.button <Enter> {Toolbar::ShowToolTip "[mc {Insert As Sibling}]" [winfo rootx %W] [winfo rooty %W]}
- bind $fraToolbar.fraSibling.button <Leave> Toolbar::HideToolTip
- set _fraRelation_(CHILD) [frame $fraToolbar.fraChild -background red -height $_height_ -width $_width_]
- pack $fraToolbar.fraChild -padx 1 -pady 1
- pack propagate $_fraRelation_(CHILD) 0
- set _butRelation_(CHILD) [button $fraToolbar.fraChild.button -command {Toolbar::UpdateRelation CHILD
- Toolbar::UpdateToolbar 0} -image "[Icon::GetIconImage child]" -takefocus 0]
- pack $fraToolbar.fraChild.button -padx 1 -pady 1
- bind $fraToolbar.fraChild.button <Enter> {Toolbar::ShowToolTip "[mc {Insert As Child}]" [winfo rootx %W] [winfo rooty %W]}
- bind $fraToolbar.fraChild.button <Leave> Toolbar::HideToolTip
- AddSeparator $fraToolbar top
- # make frame and buttons for widgets
- set _frame_(widget) [frame $fraToolbar.widgets -bd 0]
-
- # icon at top to switch to special objects
- AddIcon $_frame_(widget) top specialObjects "[mc {Special Objects}]" \
- { Toolbar::SwapToolbarFrames special }
- AddSeparator $_frame_(widget) top
-
- foreach widget [Widget::GetWidgetList] {
- AddIcon $_frame_(widget) top $widget $widget \
- "WidgetTree::AddWidget $widget \[Toolbar::GetRelation]"
- }
- pack $_frame_(widget)
-
- # make frame and buttons for special objects
- set _frame_(special) [frame $fraToolbar.special -bd 0]
-
- # icon at top to switch to widgets
- AddIcon $_frame_(special) top widgets "[mc {Widgets}]" \
- { Toolbar::SwapToolbarFrames widget }
- AddSeparator $_frame_(special) top
-
- foreach object [Special::GetSpecialObjectList] {
- AddIcon $_frame_(special) top $object $object \
- "WidgetTree::AddWidget $object \[Toolbar::GetRelation]"
- }
-
- # add icon to allow inserting main/root toplevel window
- AddSeparator $_frame_(special) top
- AddIcon $_frame_(special) top toplevel [Project::GetRootName] \
- "Special::AddSpecialObject \"[Project::GetRootName]\" \[Toolbar::GetRelation] "
- # make frame and buttons for canvas objects
- set _frame_(canvas) [frame $fraToolbar.canvas -bd 0]
- foreach object [Canvas::GetCanvasObjectList] {
- AddIcon $_frame_(canvas) top $object $object \
- "WidgetTree::AddWidget $object \[Toolbar::GetRelation]"
- }
-
- # make frame and buttons for menu entries
- set _frame_(menu) [frame $fraToolbar.menu -bd 0]
- foreach entry [MenuEntry::GetMenuEntryList] {
- AddIcon $_frame_(menu) top $entry $entry \
- "WidgetTree::AddWidget $entry \[Toolbar::GetRelation]"
- }
-
- }
- proc SwapToolbarFrames newFrame {
- variable _frame_
- variable _toolbar_
- variable _currentToolbarFrame_
-
- pack forget $_frame_($_currentToolbarFrame_)
- pack $_frame_($newFrame)
- set _currentToolbarFrame_ $newFrame
- set _toolbar_ $newFrame
- }
- proc ShowToolbar { } {
- variable _frameToolbar_
- variable _frameTree_
-
- if { [Option::GetOption widgetToolbarShow] } {
- pack $_frameToolbar_ -side left -anchor nw -before $_frameTree_
- } else {
- pack forget $_frameToolbar_
- }
-
- }
- proc UpdateRelation relation {
- variable _relation_
- variable _butRelation_
- variable _fraRelation_
- variable _background_
-
- if { $relation != $_relation_ } {
- set _relation_ $relation
- if { $_relation_ == "SIBLING" } {
- $_butRelation_(SIBLING) configure -relief sunken
- $_butRelation_(CHILD) configure -relief raised
- $_fraRelation_(SIBLING) configure -bg black
- $_fraRelation_(CHILD) configure -bg $_background_
- } elseif { $_relation_ == "CHILD" } {
- $_butRelation_(SIBLING) configure -relief raised
- $_butRelation_(CHILD) configure -relief sunken
- $_fraRelation_(SIBLING) configure -bg $_background_
- $_fraRelation_(CHILD) configure -bg black
- }
- }
-
- }
- proc UpdateToolbar { {tryDefaultRelation 1} } {
- variable _frame_
- variable _toolbar_
- variable _relation_
- variable _currentToolbarFrame_
-
- set currentNode [Tree::GetCurrentNode]
- set objectType [Tree::GetNodeItem widgetType $currentNode]
-
- if { [Canvas::WidgetIsCanvasObject $objectType] ||
- [MenuEntry::WidgetIsMenuEntry $objectType] } {
- UpdateRelation SIBLING
- SetButtonState disabled
- } else {
- # generally, use the default relation if option is set, unless this
- # is called by the sib or child toolbar button, indicating user
- # may want to override default
- if { $tryDefaultRelation } {
- if { [Option::GetOption useDefaultRelation] } {
- UpdateRelation [Main::GetDefaultRelation $objectType]
- }
- }
- SetButtonState normal
- }
-
- if { $_relation_ == "CHILD" } {
- if { $objectType == "canvas" } {
- set toolbar canvas
- } elseif { $objectType == "menu" } {
- set toolbar menu
- } else {
- # set toolbar widget
- set toolbar $_currentToolbarFrame_ ; # widget or special
- }
- }
-
- if { $_relation_ == "SIBLING" } {
- if { [Canvas::WidgetIsCanvasObject $objectType] } {
- set toolbar canvas
- } elseif { [MenuEntry::WidgetIsMenuEntry $objectType] } {
- set toolbar menu
- } else {
- # set toolbar widget
- set toolbar $_currentToolbarFrame_ ; # widget or special
- }
- }
-
- # check if need to change the toolbar
- if { $toolbar != $_toolbar_ } {
- pack forget $_frame_($_toolbar_)
- pack $_frame_($toolbar)
- set _toolbar_ $toolbar
- }
-
- }
- proc GetRelation { } {
- # returns the current setting for relation; one of SIBLING of CHILD
-
- variable _relation_
- return $_relation_
- }
- proc SetButtonState state {
- variable _butRelation_
-
- $_butRelation_(SIBLING) configure -state $state
- $_butRelation_(CHILD) configure -state $state
-
- }
- proc ShowToolTip { widget X Y } {
- # creates the toplevel window used to display the tool tip
-
- variable _toolTip_
- variable _toolTipActive_
- variable _afterID_
-
- if { ![Option::GetOption toolTipsShow] } {
- return
- }
-
- # make tool tip toplevel each time, to simplify geometry management
- set _toolTip_ [toplevel .toolTip -bg yellow]
- wm withdraw $_toolTip_
- wm overrideredirect $_toolTip_ 1
- wm geometry $_toolTip_ +[expr $X + 21]+[expr $Y + 20]
- set fraWidget [frame $_toolTip_.fraWidget -bd 1 -relief raised]
- pack $fraWidget
- pack [label $fraWidget.labWidget -bg yellow -text $widget]
-
- # display tool tip immediately if its active (i.e., its already
- # being display for neighbouring widget), otherwise after a delay
- if { $_toolTipActive_ } {
- wm deiconify $_toolTip_
- } else {
- set _afterID_ [after 1000 Toolbar::DelayToolTip]
- }
- }
- proc HideToolTip { } {
- # destroys tool tip window, and cancels possibly pending after command
-
- variable _toolTip_
-
- catch { destroy $_toolTip_ }
- CancelToolTip ; # cancel pending after command
- }
- proc DelayToolTip { } {
- # command called by 'after', to display tool tip
-
- variable _toolTip_
- variable _toolTipActive_
-
- wm deiconify $_toolTip_
- set _toolTipActive_ 1
-
- }
- proc CancelToolTip { } {
- # cancels pending tooltip command
- variable _afterID_
- catch { after cancel $_afterID_ }
-
- }
- proc AddIcon { frame side icon tooltip command } {
- variable _height_
- variable _width_
-
- # make frame to limit icon button size
- set fraBut [frame $frame.fra_$icon -height $_height_ -width $_width_]
- pack $fraBut -side $side
- pack propagate $fraBut 0
-
- # make the icon button
- set but [button $fraBut.button -image [Icon::GetIconImage $icon] \
- -relief flat -bd 1 -takefocus 0 -command $command]
- pack $but
- bindtags $but [list $but Button IconButton . all]
-
- bind $but <Enter> "%W configure -relief raised
- Toolbar::ShowToolTip \"$tooltip\" \[winfo rootx %W] \[winfo rooty %W]"
-
- }
- proc AddSeparator { frame side } {
- # get unique name for this separator
- set i 0
- while { [winfo exists $frame.fraSeparator$i] } {
- incr i
- }
-
- if { $side == "left" || $side == "right" } {
- set fraSeparator [frame $frame.fraSeparator$i -width 2 \
- -relief sunken -bd 3]
- pack $fraSeparator -side $side -fill y -padx 2 -pady 2
- } else {
- set fraSeparator [frame $frame.fraSeparator$i -height 2 \
- -relief sunken -bd 3]
- pack $fraSeparator -side $side -fill x -padx 2 -pady 1
- }
-
- }
- }