toolbar.tcl | searchcode

/lib/toolbar.tcl

https://gitlab.com/OpenSourceMirror/tkbuilder
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
	}
	
    }
}