# wtree.tcl --
#
# Part of: wtree
# Contents: the package
# Date: Sun Sep 21, 2003
#
# Abstract
#
# This module provides the ability to organise toplevel widgets
# in a tree hierarchy and to define groups in it. Groups are used
# map/unmap sets of windows together and to configure windows to
# give the focus to other selected windows.
#
# Copyright (c) 2003 Marco Maggi
#
# The author 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 AUTHOR 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 AUTHOR HAVE BEEN ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
#
# THE AUTHOR 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 AUTHOR AND DISTRIBUTORS HAVE NO OBLIGATION TO PROVIDE
# MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
#
# $Id: 9988,v 1.4 2006-11-28 19:00:35 jcw Exp $
package require Tk 8.4
namespace eval tk {
namespace export \[a-z\]*
set ns [namespace current]
foreach c {
bind bindtags button canvas
checkbutton destroy entry focus
frame grid label listbox
lower menu menubutton message
option pack place radiobutton
raise scrollbar spinbox text
toplevel wm winfo image
labelframe scale event font
tk
} {
interp alias {} ${ns}::$c {} ::$c
}
interp alias {} ${ns}::wait {} ::tkwait
unset ns c
}
namespace eval base {
namespace export \[a-z\]*
namespace eval tk { namespace import ::tk::bindtags }
}
proc base::tagadd { widget tag {pos 1} } {
tk::bindtags $widget [linsert [tk::bindtags $widget] $pos $tag]
}
proc base::tagdel { widget tag } {
set idx [lsearch [set lst [tk::bindtags $widget]] $tag]
tk::bindtags $widget [lreplace $lst $idx $idx]
}
namespace eval wtree {
namespace eval tk {
namespace import ::tk::focus ::tk::wm \
::tk::raise ::tk::bind ::tk::winfo
}
namespace eval base {
namespace import ::base::tagadd ::base::tagdel
}
# This is the variable in which the tree is stored. The keys have
# the format "<window>:<attribute>", where <window> is the pathname
# of the toplevel window.
variable tree
set tree(.:parent) .
set tree(.:children) {}
set tree(.:tofocus) {}
set tree(.:focusmode) keep
set tree(.:ismapped) 0
set ns [namespace current]
tk::bind UWPTagWTreeWindow <FocusIn> "+${ns}::focus %W"
tk::bind UWPTagWTreeWindow <Destroy> "+${ns}::forget %W"
tk::bind UWPTagWTreeWindow <Map> "+${ns}::map %W"
tk::bind UWPTagWTreeWindow <Unmap> "+${ns}::unmap %W"
unset ns
}
proc wtree::register { window {parent .} } {
variable tree
lappend tree($parent:children) $window
set tree($window:parent) $parent
set tree($window:children) {}
set tree($window:tofocus) {}
set tree($window:focusmode) keep
set tree($window:ismapped) [tk::winfo ismapped $window]
base::tagadd $window UWPTagWTreeWindow
return
}
proc wtree::forget { window } {
variable tree
# Remove the window from its parent list.
set parent $tree($window:parent)
set idx [lsearch [set lst $tree($parent:children)] $window]
set tree($parent:children) [lreplace $lst $idx $idx]
if { [string equal $tree($parent:tofocus) $window] } {
set tree($parent:tofocus) {}
}
# Make the children sons of the root window.
foreach child $tree($window:children) {
set tree($child:parent) .
}
# Free resources.
unset tree($window:parent) tree($window:children) \
tree($window:tofocus) tree($window:focusmode) \
tree($window:ismapped)
# Remove the wtree tag from the window's tag list.
base::tagdel $window UWPTagWTreeWindow
return
}
proc wtree::exists { window } {
variable tree
return [info exists tree($window:children)]
}
proc wtree::get_root_windows {} {
variable tree
return $tree(.:children)
}
proc wtree::get_window_parent { window } {
variable tree
return $tree($window:parent)
}
proc wtree::get_window_children { window } {
variable tree
return $tree($window:children)
}
proc wtree::set_focus_mode { window mode } {
variable tree
set tree($window:focusmode) $mode
}
proc wtree::set_focus_window { window child } {
variable tree
set tree($window:tofocus) $child
}
proc wtree::focus { window } {
variable tree
if { ! $tree($window:ismapped) } {
return
}
# Scenario: a data window is created and takes the focus; an ontop
# dialog window is created as child of the data window; the data
# window takes the focus; an error window is created as child of the
# data window and takes the focus; a request is sent to the dialog
# window to take the focus.
#
# In this case the dialog must give the focus to the data
# window.
set parent $tree($window:parent)
if { ! [string equal $parent .] } {
set ptf $tree($parent:tofocus)
if {
[string equal $tree($window:focusmode) ontop] &&
([string length $ptf] != 0) && (! [string equal $ptf $window])
} {
tk::focus $parent
return 0
}
}
# If this window has no focus-thief registered: focus it and return.
tk::raise $window
set tofocus $tree($window:tofocus)
if { [string length $tofocus] == 0 } {
tk::focus $window
return 1
}
# This window has a focus-thief registered. If its focus mode is
# "keep" focus it and return.
#
# If its mode is "ontop": raise it. Then descend the tree following
# the path of "tofocus" windows, raising all of them: if a window
# with no focus-thief is found: return; if a window with "keep" mode
# is found: focus it and return.
tk::wm deiconify $tofocus
switch $tree($tofocus:focusmode) {
keep {
tk::focus $tofocus
return 0
}
ontop {
tk::raise $tofocus
set child $tree($tofocus:tofocus)
while { [string length $child] } {
if { [string equal $tree($child:focusmode) keep] } {
tk::focus $child
return 0
}
set child $tree($child:tofocus)
}
}
}
return 1
}
# If this window: is not a root window, is registered
# as focus-thief for its parent; and the parent window: is
# not mapped; then the parent window is mapped.
#
# If this window has a focus-thief and this child window is
# not mapped: it's mapped.
#
# If one of the children of this window has focus mode set
# to "ontop" and is unmapped: it's mapped.
#
proc wtree::map { window } {
variable tree
set tree($window:ismapped) 1
if {
[string equal $tree($window:focusmode) keep] ||
[string equal $tree($window:focusmode) ontop]
} {
set parent $tree($window:parent)
if {
[string length $parent] &&
[string equal $tree($parent:tofocus) $window] &&
(! $tree($parent:ismapped))
} {
tk::wm deiconify $parent
set tree($parent:ismapped) 1
}
}
set tofocus $tree($window:tofocus)
if { [string length $tofocus] && (! $tree($tofocus:ismapped)) } {
tk::wm deiconify $tofocus
set tree($tofocus:ismapped) 1
}
foreach child $tree($window:children) {
if { [string equal $tofocus $child] } { continue }
if {
[string equal $tree($child:focusmode) ontop] ||
(! $tree($child:ismapped))
} {
tk::wm deiconify $child
set tree($child:ismapped) 1
}
}
return
}
# Registers the event in the "ismapped" state of the window.
#
# If this window: is not a root window, is registered
# as focus-thief for its parent; and the parent window: is
# mapped; then the parent window is unmapped.
#
# If this window has a focus-thief and this child window is
# mapped: it's unmapped.
#
# If one of the children of this window has focus mode set
# to "ontop" ans is mapped: it's unmapped.
#
# Returns the empty string.
proc wtree::unmap { window } {
variable tree
set tree($window:ismapped) 0
if {
[string equal $tree($window:focusmode) keep] ||
[string equal $tree($window:focusmode) ontop]
} {
set parent $tree($window:parent)
if {
[string length $parent] &&
[string equal $tree($parent:tofocus) $window] &&
($tree($parent:ismapped))
} {
tk::wm withdraw $window
tk::wm iconify $parent
set tree($parent:ismapped) 0
}
}
set tofocus $tree($window:tofocus)
if { [string length $tofocus] && ($tree($tofocus:ismapped)) } {
tk::wm withdraw $tofocus
set tree($tofocus:ismapped) 0
}
foreach child $tree($window:children) {
if { [string equal $tofocus $child] } { continue }
if {
[string equal $tree($child:focusmode) ontop] &&
($tree($child:ismapped))
} {
tk::wm withdraw $child
set tree($child:ismapped) 0
}
}
return
}
### end of file