# Hierarchy
# ----------------------------------------------------------------------
# Hierarchical data viewer. Manages a list of nodes that can be
# expanded or collapsed. Individual nodes can be highlighted.
# Clicking with the right mouse button on any item brings up a
# special item menu. Clicking on the background area brings up
# a different popup menu.
# ----------------------------------------------------------------------
# AUTHOR: Michael J. McLennan
# Bell Labs Innovations for Lucent Technologies
# mmclennan@lucent.com
#
# Mark L. Ulferts
# DSC Communications
# mulferts@austin.dsccc.com
#
# RCS: $Id: hierarchy.itk,v 1.9 2002/09/06 16:27:03 smithc Exp $
# ----------------------------------------------------------------------
# Copyright (c) 1996 Lucent Technologies
# ======================================================================
# Permission to use, copy, modify, and distribute this software and its
# documentation for any purpose and without fee is hereby granted,
# provided that the above copyright notice appear in all copies and that
# both that the copyright notice and warranty disclaimer appear in
# supporting documentation, and that the names of Lucent Technologies
# any of their entities not be used in advertising or publicity
# pertaining to distribution of the software without specific, written
# prior permission.
#
# Lucent Technologies disclaims all warranties with regard to this
# software, including all implied warranties of merchantability and
# fitness. In no event shall Lucent Technologies be liable for any
# special, indirect or consequential damages or any damages whatsoever
# resulting from loss of use, data or profits, whether in an action of
# contract, negligence or other tortuous action, arising out of or in
# connection with the use or performance of this software.
#
# ----------------------------------------------------------------------
# Copyright (c) 1996 DSC Technologies Corporation
# ======================================================================
# Permission to use, copy, modify, distribute and license this software
# and its documentation for any purpose, and without fee or written
# agreement with DSC, is hereby granted, provided that the above copyright
# notice appears in all copies and that both the copyright notice and
# warranty disclaimer below appear in supporting documentation, and that
# the names of DSC Technologies Corporation or DSC Communications
# Corporation not be used in advertising or publicity pertaining to the
# software without specific, written prior permission.
#
# DSC DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
# ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, 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. IN NO EVENT SHALL
# DSC BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
# ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
# WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTUOUS ACTION,
# ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
# SOFTWARE.
# ======================================================================
#
# Usual options.
#
itk::usual Hierarchy {
keep -cursor -textfont -font
keep -background -foreground -textbackground
keep -selectbackground -selectforeground
}
# ------------------------------------------------------------------
# HIERARCHY
# ------------------------------------------------------------------
itcl::class iwidgets::Hierarchy {
inherit iwidgets::Scrolledwidget
constructor {args} {}
destructor {}
itk_option define -alwaysquery alwaysQuery AlwaysQuery 0
itk_option define -closedicon closedIcon Icon {}
itk_option define -dblclickcommand dblClickCommand Command {}
itk_option define -expanded expanded Expanded 0
itk_option define -filter filter Filter 0
itk_option define -font font Font \
-*-Courier-Medium-R-Normal--*-120-*-*-*-*-*-*
itk_option define -height height Height 0
itk_option define -iconcommand iconCommand Command {}
itk_option define -icondblcommand iconDblCommand Command {}
itk_option define -imagecommand imageCommand Command {}
itk_option define -imagedblcommand imageDblCommand Command {}
itk_option define -imagemenuloadcommand imageMenuLoadCommand Command {}
itk_option define -markbackground markBackground Foreground #a0a0a0
itk_option define -markforeground markForeground Background Black
itk_option define -nodeicon nodeIcon Icon {}
itk_option define -openicon openIcon Icon {}
itk_option define -querycommand queryCommand Command {}
itk_option define -selectcommand selectCommand Command {}
itk_option define -selectbackground selectBackground Foreground #c3c3c3
itk_option define -selectforeground selectForeground Background Black
itk_option define -textmenuloadcommand textMenuLoadCommand Command {}
itk_option define -visibleitems visibleItems VisibleItems 80x24
itk_option define -width width Width 0
public {
method clear {}
method collapse {node}
method current {}
method draw {{when -now}}
method expand {node}
method expanded {node}
method expState { }
method mark {op args}
method prune {node}
method refresh {node}
method selection {op args}
method toggle {node}
method bbox {index}
method compare {index1 op index2}
method debug {args} {eval $args}
method delete {first {last {}}}
method dlineinfo {index}
method dump {args}
method get {index1 {index2 {}}}
method index {index}
method insert {args}
method scan {option args}
method search {args}
method see {index}
method tag {op args}
method window {option args}
method xview {args}
method yview {args}
}
protected {
method _contents {uid}
method _post {x y}
method _drawLevel {node indent}
method _select {x y}
method _deselectSubNodes {uid}
method _deleteNodeInfo {uid}
method _getParent {uid}
method _getHeritage {uid}
method _isInternalTag {tag}
method _iconSelect {node icon}
method _iconDblSelect {node icon}
method _imageSelect {node}
method _imageDblClick {node}
method _imagePost {node image type x y}
method _double {x y}
}
private {
method _configureTags {}
variable _filterCode "" ;# Compact view flag.
variable _hcounter 0 ;# Counter for hierarchy icons
variable _icons ;# Array of user icons by uid
variable _images ;# Array of our icons by uid
variable _indents ;# Array of indentation by uid
variable _marked ;# Array of marked nodes by uid
variable _markers "" ;# List of markers for level being drawn
variable _nodes ;# Array of subnodes by uid
variable _pending "" ;# Pending draw flag
variable _posted "" ;# List of tags at posted menu position
variable _selected ;# Array of selected nodes by uid
variable _tags ;# Array of user tags by uid
variable _text ;# Array of displayed text by uid
variable _states ;# Array of selection state by uid
variable _ucounter 0 ;# Counter for user icons
}
}
#
# Provide a lowercased access method for the Hierarchy class.
#
proc ::iwidgets::hierarchy {pathName args} {
uplevel ::iwidgets::Hierarchy $pathName $args
}
#
# Use option database to override default resources of base classes.
#
option add *Hierarchy.menuCursor arrow widgetDefault
option add *Hierarchy.labelPos n widgetDefault
option add *Hierarchy.tabs 30 widgetDefault
# ------------------------------------------------------------------
# CONSTRUCTOR
# ------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::constructor {args} {
itk_option remove iwidgets::Labeledwidget::state
#
# Our -width and -height options are slightly different than
# those implemented by our base class, so we're going to
# remove them and redefine our own.
#
itk_option remove iwidgets::Scrolledwidget::width
itk_option remove iwidgets::Scrolledwidget::height
#
# Create a clipping frame which will provide the border for
# relief display.
#
itk_component add clipper {
frame $itk_interior.clipper
} {
usual
keep -borderwidth -relief -highlightthickness -highlightcolor
rename -highlightbackground -background background Background
}
grid $itk_component(clipper) -row 0 -column 0 -sticky nsew
grid rowconfigure $_interior 0 -weight 1
grid columnconfigure $_interior 0 -weight 1
#
# Create a text widget for displaying our hierarchy.
#
itk_component add list {
text $itk_component(clipper).list -wrap none -cursor center_ptr \
-state disabled -width 1 -height 1 \
-xscrollcommand \
[itcl::code $this _scrollWidget $itk_interior.horizsb] \
-yscrollcommand \
[itcl::code $this _scrollWidget $itk_interior.vertsb] \
-borderwidth 0 -highlightthickness 0
} {
usual
keep -spacing1 -spacing2 -spacing3 -tabs
rename -font -textfont textFont Font
rename -background -textbackground textBackground Background
ignore -highlightthickness -highlightcolor
ignore -insertbackground -insertborderwidth
ignore -insertontime -insertofftime -insertwidth
ignore -selectborderwidth
ignore -borderwidth
}
grid $itk_component(list) -row 0 -column 0 -sticky nsew
grid rowconfigure $itk_component(clipper) 0 -weight 1
grid columnconfigure $itk_component(clipper) 0 -weight 1
#
# Configure the command on the vertical scroll bar in the base class.
#
$itk_component(vertsb) configure \
-command [itcl::code $itk_component(list) yview]
#
# Configure the command on the horizontal scroll bar in the base class.
#
$itk_component(horizsb) configure \
-command [itcl::code $itk_component(list) xview]
#
# Configure our text component's tab settings for twenty levels.
#
set tabs ""
for {set i 1} {$i < 20} {incr i} {
lappend tabs [expr {$i*12+4}]
}
$itk_component(list) configure -tabs $tabs
#
# Add popup menus that can be configured by the user to add
# new functionality.
#
itk_component add itemMenu {
menu $itk_component(list).itemmenu -tearoff 0
} {
usual
ignore -tearoff
rename -cursor -menucursor menuCursor Cursor
}
itk_component add bgMenu {
menu $itk_component(list).bgmenu -tearoff 0
} {
usual
ignore -tearoff
rename -cursor -menucursor menuCursor Cursor
}
#
# Adjust the bind tags to remove the class bindings. Also, add
# bindings for mouse button 1 to do selection and button 3 to
# display a popup.
#
bindtags $itk_component(list) [list $itk_component(list) . all]
bind $itk_component(list) <ButtonPress-1> \
[itcl::code $this _select %x %y]
bind $itk_component(list) <Double-1> \
[itcl::code $this _double %x %y]
bind $itk_component(list) <ButtonPress-3> \
[itcl::code $this _post %x %y]
#
# Initialize the widget based on the command line options.
#
eval itk_initialize $args
}
# ------------------------------------------------------------------
# DESTRUCTOR
# ------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::destructor {} {
if {$_pending != ""} {
after cancel $_pending
}
}
# ------------------------------------------------------------------
# OPTIONS
# ------------------------------------------------------------------
# ------------------------------------------------------------------
# OPTION: -font
#
# Font used for text in the list.
# ------------------------------------------------------------------
itcl::configbody iwidgets::Hierarchy::font {
$itk_component(list) tag configure info \
-font $itk_option(-font) -spacing1 6
}
# ------------------------------------------------------------------
# OPTION: -selectbackground
#
# Background color scheme for selected nodes.
# ------------------------------------------------------------------
itcl::configbody iwidgets::Hierarchy::selectbackground {
$itk_component(list) tag configure hilite \
-background $itk_option(-selectbackground)
}
# ------------------------------------------------------------------
# OPTION: -selectforeground
#
# Foreground color scheme for selected nodes.
# ------------------------------------------------------------------
itcl::configbody iwidgets::Hierarchy::selectforeground {
$itk_component(list) tag configure hilite \
-foreground $itk_option(-selectforeground)
}
# ------------------------------------------------------------------
# OPTION: -markbackground
#
# Background color scheme for marked nodes.
# ------------------------------------------------------------------
itcl::configbody iwidgets::Hierarchy::markbackground {
$itk_component(list) tag configure lowlite \
-background $itk_option(-markbackground)
}
# ------------------------------------------------------------------
# OPTION: -markforeground
#
# Foreground color scheme for marked nodes.
# ------------------------------------------------------------------
itcl::configbody iwidgets::Hierarchy::markforeground {
$itk_component(list) tag configure lowlite \
-foreground $itk_option(-markforeground)
}
# ------------------------------------------------------------------
# OPTION: -querycommand
#
# Command executed to query the contents of each node. If this
# command contains "%n", it is replaced with the name of the desired
# node. In its simpilest form it should return the children of the
# given node as a list which will be depicted in the display.
#
# Since the names of the children are used as tags in the underlying
# text widget, each child must be unique in the hierarchy. Due to
# the unique requirement, the nodes shall be reffered to as uids
# or uid in the singular sense.
#
# {uid [uid ...]}
#
# where uid is a unique id and primary key for the hierarchy entry
#
# Should the unique requirement pose a problem, the list returned
# can take on another more extended form which enables the
# association of text to be displayed with the uids. The uid must
# still be unique, but the text does not have to obey the unique
# rule. In addition, the format also allows the specification of
# additional tags to be used on the same entry in the hierarchy
# as the uid and additional icons to be displayed just before
# the node. The tags and icons are considered to be the property of
# the user in that the hierarchy widget will not depend on any of
# their values.
#
# {{uid [text [tags [icons]]]} {uid [text [tags [icons]]]} ...}
#
# where uid is a unique id and primary key for the hierarchy entry
# text is the text to be displayed for this uid
# tags is a list of user tags to be applied to the entry
# icons is a list of icons to be displayed in front of the text
#
# The hierarchy widget does a look ahead from each node to determine
# if the node has a children. This can be cost some performace with
# large hierarchies. User's can avoid this by providing a hint in
# the user tags. A tag of "leaf" or "branch" tells the hierarchy
# widget the information it needs to know thereby avoiding the look
# ahead operation.
# ------------------------------------------------------------------
itcl::configbody iwidgets::Hierarchy::querycommand {
clear
draw -eventually
# Added for SF ticket #596111
_configureTags
}
# ------------------------------------------------------------------
# OPTION: -selectcommand
#
# Command executed to select an item in the list. If this command
# contains "%n", it is replaced with the name of the selected node.
# If it contains a "%s", it is replaced with a boolean indicator of
# the node's current selection status, where a value of 1 denotes
# that the node is currently selected and 0 that it is not.
# ------------------------------------------------------------------
itcl::configbody iwidgets::Hierarchy::selectcommand {
}
# ------------------------------------------------------------------
# OPTION: -dblclickcommand
#
# Command executed to double click an item in the list. If this command
# contains "%n", it is replaced with the name of the selected node.
# If it contains a "%s", it is replaced with a boolean indicator of
# the node's current selection status, where a value of 1 denotes
# that the node is currently selected and 0 that it is not.
#
# Douglas R. Howard, Jr.
# ------------------------------------------------------------------
itcl::configbody iwidgets::Hierarchy::dblclickcommand {
}
# ------------------------------------------------------------------
# OPTION: -iconcommand
#
# Command executed upon selection of user icons. If this command
# contains "%n", it is replaced with the name of the node the icon
# belongs to. Should it contain "%i" then the icon name is
# substituted.
# ------------------------------------------------------------------
itcl::configbody iwidgets::Hierarchy::iconcommand {
}
# ------------------------------------------------------------------
# OPTION: -icondblcommand
#
# Command executed upon double selection of user icons. If this command
# contains "%n", it is replaced with the name of the node the icon
# belongs to. Should it contain "%i" then the icon name is
# substituted.
#
# Douglas R. Howard, Jr.
# ------------------------------------------------------------------
itcl::configbody iwidgets::Hierarchy::icondblcommand {
}
# ------------------------------------------------------------------
# OPTION: -imagecommand
#
# Command executed upon selection of image icons. If this command
# contains "%n", it is replaced with the name of the node the icon
# belongs to. Should it contain "%i" then the icon name is
# substituted.
#
# Douglas R. Howard, Jr.
# ------------------------------------------------------------------
itcl::configbody iwidgets::Hierarchy::imagecommand {
}
# ------------------------------------------------------------------
# OPTION: -imagedblcommand
#
# Command executed upon double selection of user icons. If this command
# contains "%n", it is replaced with the name of the node the icon
# belongs to.
#
# Douglas R. Howard, Jr.
# ------------------------------------------------------------------
itcl::configbody iwidgets::Hierarchy::imagedblcommand {
}
# ------------------------------------------------------------------
# OPTION: -alwaysquery
#
# Boolean flag which tells the hierarchy widget weather or not
# each refresh of the display should be via a new query using
# the -querycommand option or use the values previous found the
# last time the query was made.
# ------------------------------------------------------------------
itcl::configbody iwidgets::Hierarchy::alwaysquery {
switch -- $itk_option(-alwaysquery) {
1 - true - yes - on {
;# okay
}
0 - false - no - off {
;# okay
}
default {
error "bad alwaysquery option \"$itk_option(-alwaysquery)\":\
should be boolean"
}
}
}
# ------------------------------------------------------------------
# OPTION: -filter
#
# When true only the branch nodes and selected items are displayed.
# This gives a compact view of important items.
# ------------------------------------------------------------------
itcl::configbody iwidgets::Hierarchy::filter {
switch -- $itk_option(-filter) {
1 - true - yes - on {
set newCode {set display [info exists _selected($child)]}
}
0 - false - no - off {
set newCode {set display 1}
}
default {
error "bad filter option \"$itk_option(-filter)\":\
should be boolean"
}
}
if {$newCode != $_filterCode} {
set _filterCode $newCode
draw -eventually
}
}
# ------------------------------------------------------------------
# OPTION: -expanded
#
# When true, the hierarchy will be completely expanded when it
# is first displayed. A fresh display can be triggered by
# resetting the -querycommand option.
# ------------------------------------------------------------------
itcl::configbody iwidgets::Hierarchy::expanded {
switch -- $itk_option(-expanded) {
1 - true - yes - on {
;# okay
}
0 - false - no - off {
;# okay
}
default {
error "bad expanded option \"$itk_option(-expanded)\":\
should be boolean"
}
}
}
# ------------------------------------------------------------------
# OPTION: -openicon
#
# Specifies the open icon image to be used in the hierarchy. Should
# one not be provided, then one will be generated, pixmap if
# possible, bitmap otherwise.
# ------------------------------------------------------------------
itcl::configbody iwidgets::Hierarchy::openicon {
if {$itk_option(-openicon) == {}} {
if {[lsearch [image names] openFolder] == -1} {
if {[lsearch [image types] pixmap] != -1} {
image create pixmap openFolder -data {
/* XPM */
static char * dir_opened [] = {
"16 16 4 1",
/* colors */
". c grey85 m white g4 grey90",
"b c black m black g4 black",
"y c yellow m white g4 grey80",
"g c grey70 m white g4 grey70",
/* pixels */
"................",
"................",
"................",
"..bbbb..........",
".bggggb.........",
"bggggggbbbbbbb..",
"bggggggggggggb..",
"bgbbbbbbbbbbbbbb",
"bgbyyyyyyyyyyybb",
"bbyyyyyyyyyyyyb.",
"bbyyyyyyyyyyybb.",
"byyyyyyyyyyyyb..",
"bbbbbbbbbbbbbb..",
"................",
"................",
"................"};
}
} else {
image create bitmap openFolder -data {
#define open_width 16
#define open_height 16
static char open_bits[] = {
0x00, 0x00, 0x00, 0x00, 0x3c, 0x00, 0x42, 0x00,
0x81, 0x3f, 0x01, 0x20, 0xf9, 0xff, 0x0d, 0xc0,
0x07, 0x40, 0x03, 0x60, 0x01, 0x20, 0x01, 0x30,
0xff, 0x1f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};
}
}
}
set itk_option(-openicon) openFolder
} else {
if {[lsearch [image names] $itk_option(-openicon)] == -1} {
error "bad openicon option \"$itk_option(-openicon)\":\
should be an existing image"
}
}
}
# ------------------------------------------------------------------
# OPTION: -closedicon
#
# Specifies the closed icon image to be used in the hierarchy.
# Should one not be provided, then one will be generated, pixmap if
# possible, bitmap otherwise.
# ------------------------------------------------------------------
itcl::configbody iwidgets::Hierarchy::closedicon {
if {$itk_option(-closedicon) == {}} {
if {[lsearch [image names] closedFolder] == -1} {
if {[lsearch [image types] pixmap] != -1} {
image create pixmap closedFolder -data {
/* XPM */
static char *dir_closed[] = {
"16 16 3 1",
". c grey85 m white g4 grey90",
"b c black m black g4 black",
"y c yellow m white g4 grey80",
"................",
"................",
"................",
"..bbbb..........",
".byyyyb.........",
"bbbbbbbbbbbbbb..",
"byyyyyyyyyyyyb..",
"byyyyyyyyyyyyb..",
"byyyyyyyyyyyyb..",
"byyyyyyyyyyyyb..",
"byyyyyyyyyyyyb..",
"byyyyyyyyyyyyb..",
"bbbbbbbbbbbbbb..",
"................",
"................",
"................"};
}
} else {
image create bitmap closedFolder -data {
#define closed_width 16
#define closed_height 16
static char closed_bits[] = {
0x00, 0x00, 0x00, 0x00, 0x78, 0x00, 0x84, 0x00,
0xfe, 0x7f, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40,
0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40,
0xfe, 0x7f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};
}
}
}
set itk_option(-closedicon) closedFolder
} else {
if {[lsearch [image names] $itk_option(-closedicon)] == -1} {
error "bad closedicon option \"$itk_option(-closedicon)\":\
should be an existing image"
}
}
}
# ------------------------------------------------------------------
# OPTION: -nodeicon
#
# Specifies the node icon image to be used in the hierarchy. Should
# one not be provided, then one will be generated, pixmap if
# possible, bitmap otherwise.
# ------------------------------------------------------------------
itcl::configbody iwidgets::Hierarchy::nodeicon {
if {$itk_option(-nodeicon) == {}} {
if {[lsearch [image names] nodeFolder] == -1} {
if {[lsearch [image types] pixmap] != -1} {
image create pixmap nodeFolder -data {
/* XPM */
static char *dir_node[] = {
"16 16 3 1",
". c grey85 m white g4 grey90",
"b c black m black g4 black",
"y c yellow m white g4 grey80",
"................",
"................",
"................",
"...bbbbbbbbbbb..",
"..bybyyyyyyyyb..",
".byybyyyyyyyyb..",
"byyybyyyyyyyyb..",
"bbbbbyyyyyyyyb..",
"byyyyyyyyyyyyb..",
"byyyyyyyyyyyyb..",
"byyyyyyyyyyyyb..",
"byyyyyyyyyyyyb..",
"bbbbbbbbbbbbbb..",
"................",
"................",
"................"};
}
} else {
image create bitmap nodeFolder -data {
#define node_width 16
#define node_height 16
static char node_bits[] = {
0x00, 0x00, 0x00, 0x00, 0xe0, 0x7f, 0x50, 0x40,
0x48, 0x40, 0x44, 0x40, 0x42, 0x40, 0x7e, 0x40,
0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40,
0xfe, 0x7f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};
}
}
}
set itk_option(-nodeicon) nodeFolder
} else {
if {[lsearch [image names] $itk_option(-nodeicon)] == -1} {
error "bad nodeicon option \"$itk_option(-nodeicon)\":\
should be an existing image"
}
}
}
# ------------------------------------------------------------------
# OPTION: -width
#
# Specifies the width of the hierarchy widget as an entire unit.
# The value may be specified in any of the forms acceptable to
# Tk_GetPixels. Any additional space needed to display the other
# components such as labels, margins, and scrollbars force the text
# to be compressed. A value of zero along with the same value for
# the height causes the value given for the visibleitems option
# to be applied which administers geometry constraints in a different
# manner.
# ------------------------------------------------------------------
itcl::configbody iwidgets::Hierarchy::width {
if {$itk_option(-width) != 0} {
set shell [lindex [grid info $itk_component(clipper)] 1]
#
# Due to a bug in the tk4.2 grid, we have to check the
# propagation before setting it. Setting it to the same
# value it already is will cause it to toggle.
#
if {[grid propagate $shell]} {
grid propagate $shell no
}
$itk_component(list) configure -width 1
$shell configure \
-width [winfo pixels $shell $itk_option(-width)]
} else {
configure -visibleitems $itk_option(-visibleitems)
}
}
# ------------------------------------------------------------------
# OPTION: -height
#
# Specifies the height of the hierarchy widget as an entire unit.
# The value may be specified in any of the forms acceptable to
# Tk_GetPixels. Any additional space needed to display the other
# components such as labels, margins, and scrollbars force the text
# to be compressed. A value of zero along with the same value for
# the width causes the value given for the visibleitems option
# to be applied which administers geometry constraints in a different
# manner.
# ------------------------------------------------------------------
itcl::configbody iwidgets::Hierarchy::height {
if {$itk_option(-height) != 0} {
set shell [lindex [grid info $itk_component(clipper)] 1]
#
# Due to a bug in the tk4.2 grid, we have to check the
# propagation before setting it. Setting it to the same
# value it already is will cause it to toggle.
#
if {[grid propagate $shell]} {
grid propagate $shell no
}
$itk_component(list) configure -height 1
$shell configure \
-height [winfo pixels $shell $itk_option(-height)]
} else {
configure -visibleitems $itk_option(-visibleitems)
}
}
# ------------------------------------------------------------------
# OPTION: -visibleitems
#
# Specified the widthxheight in characters and lines for the text.
# This option is only administered if the width and height options
# are both set to zero, otherwise they take precedence. With the
# visibleitems option engaged, geometry constraints are maintained
# only on the text. The size of the other components such as
# labels, margins, and scroll bars, are additive and independent,
# effecting the overall size of the scrolled text. In contrast,
# should the width and height options have non zero values, they
# are applied to the scrolled text as a whole. The text is
# compressed or expanded to maintain the geometry constraints.
# ------------------------------------------------------------------
itcl::configbody iwidgets::Hierarchy::visibleitems {
if {[regexp {^[0-9]+x[0-9]+$} $itk_option(-visibleitems)]} {
if {($itk_option(-width) == 0) && \
($itk_option(-height) == 0)} {
set chars [lindex [split $itk_option(-visibleitems) x] 0]
set lines [lindex [split $itk_option(-visibleitems) x] 1]
set shell [lindex [grid info $itk_component(clipper)] 1]
#
# Due to a bug in the tk4.2 grid, we have to check the
# propagation before setting it. Setting it to the same
# value it already is will cause it to toggle.
#
if {! [grid propagate $shell]} {
grid propagate $shell yes
}
$itk_component(list) configure -width $chars -height $lines
}
} else {
error "bad visibleitems option\
\"$itk_option(-visibleitems)\": should be\
widthxheight"
}
}
# ------------------------------------------------------------------
# OPTION: -textmenuloadcommand
#
# Dynamically loads the popup menu based on what was selected.
#
# Douglas R. Howard, Jr.
# ------------------------------------------------------------------
itcl::configbody iwidgets::Hierarchy::textmenuloadcommand {}
# ------------------------------------------------------------------
# OPTION: -imagemenuloadcommand
#
# Dynamically loads the popup menu based on what was selected.
#
# Douglas R. Howard, Jr.
# ------------------------------------------------------------------
itcl::configbody iwidgets::Hierarchy::imagemenuloadcommand {}
# ------------------------------------------------------------------
# PUBLIC METHODS
# ------------------------------------------------------------------
# ----------------------------------------------------------------------
# PUBLIC METHOD: clear
#
# Removes all items from the display including all tags and icons.
# The display will remain empty until the -filter or -querycommand
# options are set.
# ----------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::clear {} {
$itk_component(list) configure -state normal -cursor watch
$itk_component(list) delete 1.0 end
$itk_component(list) configure -state disabled -cursor $itk_option(-cursor)
# Clear the tags
eval $itk_component(list) tag delete [$itk_component(list) tag names]
catch {unset _nodes}
catch {unset _text}
catch {unset _tags}
catch {unset _icons}
catch {unset _states}
catch {unset _images}
catch {unset _indents}
catch {unset _marked}
catch {unset _selected}
set _markers ""
set _posted ""
set _ucounter 0
set _hcounter 0
foreach mark [$itk_component(list) mark names] {
$itk_component(list) mark unset $mark
}
return
}
# ----------------------------------------------------------------------
# PUBLIC METHOD: selection option ?uid uid...?
#
# Handles all operations controlling selections in the hierarchy.
# Selections may be cleared, added, removed, or queried. The add and
# remove options accept a series of unique ids.
# ----------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::selection {op args} {
switch -- $op {
clear {
$itk_component(list) tag remove hilite 1.0 end
catch {unset _selected}
return
}
add {
foreach node $args {
set _selected($node) 1
catch {
$itk_component(list) tag add hilite \
"$node.first" "$node.last"
}
}
}
remove {
foreach node $args {
catch {
unset _selected($node)
$itk_component(list) tag remove hilite \
"$node.first" "$node.last"
}
}
}
get {
return [array names _selected]
}
default {
error "bad selection operation \"$op\":\
should be add, remove, clear or get"
}
}
}
# ----------------------------------------------------------------------
# PUBLIC METHOD: mark option ?arg arg...?
#
# Handles all operations controlling marks in the hierarchy. Marks may
# be cleared, added, removed, or queried. The add and remove options
# accept a series of unique ids.
# ----------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::mark {op args} {
switch -- $op {
clear {
$itk_component(list) tag remove lowlite 1.0 end
catch {unset _marked}
return
}
add {
foreach node $args {
set _marked($node) 1
catch {
$itk_component(list) tag add lowlite \
"$node.first" "$node.last"
}
}
}
remove {
foreach node $args {
catch {
unset _marked($node)
$itk_component(list) tag remove lowlite \
"$node.first" "$node.last"
}
}
}
get {
return [array names _marked]
}
default {
error "bad mark operation \"$op\":\
should be add, remove, clear or get"
}
}
}
# ----------------------------------------------------------------------
# PUBLIC METHOD: current
#
# Returns the node that was most recently selected by the right mouse
# button when the item menu was posted. Usually used by the code
# in the item menu to figure out what item is being manipulated.
# ----------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::current {} {
return $_posted
}
# ----------------------------------------------------------------------
# PUBLIC METHOD: expand node
#
# Expands the hierarchy beneath the specified node. Since this can take
# a moment for large hierarchies, the cursor will be changed to a watch
# during the expansion.
# ----------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::expand {node} {
if {! [info exists _states($node)]} {
error "bad expand node argument: \"$node\", the node doesn't exist"
}
if {!$_states($node) && \
(([lsearch $_tags($node) branch] != -1) || \
([llength [_contents $node]] > 0))} {
$itk_component(list) configure -state normal -cursor watch
update
#
# Get the indentation level for the node.
#
set indent $_indents($node)
set _markers ""
$itk_component(list) mark set insert "$node:start"
_drawLevel $node $indent
#
# Following the draw, all our markers need adjusting.
#
foreach {name index} $_markers {
$itk_component(list) mark set $name $index
}
#
# Set the image to be the open icon, denote the new state,
# and set the cursor back to normal along with the state.
#
$_images($node) configure -image $itk_option(-openicon)
set _states($node) 1
$itk_component(list) configure -state disabled \
-cursor $itk_option(-cursor)
}
}
# ----------------------------------------------------------------------
# PUBLIC METHOD: collapse node
#
# Collapses the hierarchy beneath the specified node. Since this can
# take a moment for large hierarchies, the cursor will be changed to a
# watch during the expansion.
# ----------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::collapse {node} {
if {! [info exists _states($node)]} {
error "bad collapse node argument: \"$node\", the node doesn't exist"
}
if {[info exists _states($node)] && $_states($node) && \
(([lsearch $_tags($node) branch] != -1) || \
([llength [_contents $node]] > 0))} {
$itk_component(list) configure -state normal -cursor watch
update
_deselectSubNodes $node
$itk_component(list) delete "$node:start" "$node:end"
catch {$_images($node) configure -image $itk_option(-closedicon)}
set _states($node) 0
$itk_component(list) configure -state disabled \
-cursor $itk_option(-cursor)
}
}
# ----------------------------------------------------------------------
# PUBLIC METHOD: toggle node
#
# Toggles the hierarchy beneath the specified node. If the hierarchy
# is currently expanded, then it is collapsed, and vice-versa.
# ----------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::toggle {node} {
if {! [info exists _states($node)]} {
error "bad toggle node argument: \"$node\", the node doesn't exist"
}
if {$_states($node)} {
collapse $node
} else {
expand $node
}
}
# ----------------------------------------------------------------------
# PUBLIC METHOD: prune node
#
# Removes a particular node from the hierarchy.
# ----------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::prune {node} {
#
# While we're working, change the state and cursor so we can
# edit the text and give a busy visual clue.
#
$itk_component(list) configure -state normal -cursor watch
#
# Recursively delete all the subnode information from our internal
# arrays and remove all the tags.
#
_deleteNodeInfo $node
#
# If the mark $node:end exists then the node has decendents so
# so we'll remove from the mark $node:start to $node:end in order
# to delete all the subnodes below it in the text.
#
if {[lsearch [$itk_component(list) mark names] $node:end] != -1} {
$itk_component(list) delete $node:start $node:end
$itk_component(list) mark unset $node:end
}
#
# Next we need to remove the node itself. Using the ranges for
# its tag we'll remove it from line start to the end plus one
# character which takes us to the start of the next node.
#
foreach {start end} [$itk_component(list) tag ranges $node] {
$itk_component(list) delete "$start linestart" "$end + 1 char"
}
#
# Delete the tag for this node.
#
$itk_component(list) tag delete $node
#
# The node must be removed from the list of subnodes for its parent.
# We don't really have a clean way to do upwards referencing, so
# the dirty way will have to do. We'll cycle through each node
# and if this node is in its list of subnodes, we'll remove it.
#
foreach uid [array names _nodes] {
if {[set index [lsearch $_nodes($uid) $node]] != -1} {
set _nodes($uid) [lreplace $_nodes($uid) $index $index]
}
}
#
# We're done, so change the state and cursor back to their
# original values.
#
$itk_component(list) configure -state disabled -cursor $itk_option(-cursor)
}
# ----------------------------------------------------------------------
# PUBLIC METHOD: draw ?when?
#
# Performs a complete draw of the entire hierarchy.
# ----------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::draw {{when -now}} {
if {$when == "-eventually"} {
if {$_pending == ""} {
set _pending [after idle [itcl::code $this draw -now]]
}
return
} elseif {$when != "-now"} {
error "bad when option \"$when\": should be -eventually or -now"
}
$itk_component(list) configure -state normal -cursor watch
update
$itk_component(list) delete 1.0 end
catch {unset _images}
set _markers ""
_drawLevel "" ""
foreach {name index} $_markers {
$itk_component(list) mark set $name $index
}
$itk_component(list) configure -state disabled -cursor $itk_option(-cursor)
set _pending ""
}
# ----------------------------------------------------------------------
# PUBLIC METHOD: refresh node
#
# Performs a redraw of a specific node. If that node is currently
# not visible, then no action is taken.
# ----------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::refresh {node} {
if {! [info exists _nodes($node)]} {
error "bad refresh node argument: \"$node\", the node doesn't exist"
}
if {! $_states($node)} {return}
foreach parent [_getHeritage $node] {
if {! $_states($parent)} {return}
}
$itk_component(list) configure -state normal -cursor watch
$itk_component(list) delete $node:start $node:end
set _markers ""
$itk_component(list) mark set insert "$node:start"
set indent $_indents($node)
_drawLevel $node $indent
foreach {name index} $_markers {
$itk_component(list) mark set $name $index
}
$itk_component(list) configure -state disabled -cursor $itk_option(-cursor)
}
# ------------------------------------------------------------------
# THIN WRAPPED TEXT METHODS:
#
# The following methods are thin wraps of standard text methods.
# Consult the Tk text man pages for functionallity and argument
# documentation.
# ------------------------------------------------------------------
# ------------------------------------------------------------------
# PUBLIC METHOD: bbox index
#
# Returns four element list describing the bounding box for the list
# item at index
# ------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::bbox {index} {
return [$itk_component(list) bbox $index]
}
# ------------------------------------------------------------------
# PUBLIC METHOD compare index1 op index2
#
# Compare indices according to relational operator.
# ------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::compare {index1 op index2} {
return [$itk_component(list) compare $index1 $op $index2]
}
# ------------------------------------------------------------------
# PUBLIC METHOD delete first ?last?
#
# Delete a range of characters from the text.
# ------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::delete {first {last {}}} {
$itk_component(list) configure -state normal -cursor watch
$itk_component(list) delete $first $last
$itk_component(list) configure -state disabled -cursor $itk_option(-cursor)
}
# ------------------------------------------------------------------
# PUBLIC METHOD dump ?switches? index1 ?index2?
#
# Returns information about the contents of the text widget from
# index1 to index2.
# ------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::dump {args} {
return [eval $itk_component(list) dump $args]
}
# ------------------------------------------------------------------
# PUBLIC METHOD dlineinfo index
#
# Returns a five element list describing the area occupied by the
# display line containing index.
# ------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::dlineinfo {index} {
return [$itk_component(list) dlineinfo $index]
}
# ------------------------------------------------------------------
# PUBLIC METHOD get index1 ?index2?
#
# Return text from start index to end index.
# ------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::get {index1 {index2 {}}} {
return [$itk_component(list) get $index1 $index2]
}
# ------------------------------------------------------------------
# PUBLIC METHOD index index
#
# Return position corresponding to index.
# ------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::index {index} {
return [$itk_component(list) index $index]
}
# ------------------------------------------------------------------
# PUBLIC METHOD insert index chars ?tagList?
#
# Insert text at index.
# ------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::insert {args} {
$itk_component(list) configure -state normal -cursor watch
eval $itk_component(list) insert $args
$itk_component(list) configure -state disabled -cursor $itk_option(-cursor)
}
# ------------------------------------------------------------------
# PUBLIC METHOD scan option args
#
# Implements scanning on texts.
# ------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::scan {option args} {
eval $itk_component(list) scan $option $args
}
# ------------------------------------------------------------------
# PUBLIC METHOD search ?switches? pattern index ?varName?
#
# Searches the text for characters matching a pattern.
# ------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::search {args} {
return [eval $itk_component(list) search $args]
}
# ------------------------------------------------------------------
# PUBLIC METHOD see index
#
# Adjusts the view in the window so the character at index is
# visible.
# ------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::see {index} {
$itk_component(list) see $index
}
# ------------------------------------------------------------------
# PUBLIC METHOD tag option ?arg arg ...?
#
# Manipulate tags dependent on options.
# ------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::tag {op args} {
return [eval $itk_component(list) tag $op $args]
}
# ------------------------------------------------------------------
# PUBLIC METHOD window option ?arg arg ...?
#
# Manipulate embedded windows.
# ------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::window {option args} {
return [eval $itk_component(list) window $option $args]
}
# ----------------------------------------------------------------------
# PUBLIC METHOD: xview args
#
# Thin wrap of the text widget's xview command.
# ----------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::xview {args} {
return [eval itk_component(list) xview $args]
}
# ----------------------------------------------------------------------
# PUBLIC METHOD: yview args
#
# Thin wrap of the text widget's yview command.
# ----------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::yview {args} {
return [eval $itk_component(list) yview $args]
}
# ----------------------------------------------------------------------
# PUBLIC METHOD: expanded node
#
# Tells if a node is expanded or collapsed
#
# Douglas R. Howard, Jr.
# ----------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::expanded {node} {
if {! [info exists _states($node)]} {
error "bad collapse node argument: \"$node\", the node doesn't exist"
}
return $_states($node)
}
# ----------------------------------------------------------------------
# PUBLIC METHOD: expState
#
# Returns a list of all expanded nodes
#
# Douglas R. Howard, Jr.
# ----------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::expState {} {
set nodes [_contents ""]
set open ""
set i 0
while {1} {
if {[info exists _states([lindex $nodes $i])] &&
$_states([lindex $nodes $i])} {
lappend open [lindex $nodes $i]
foreach child [_contents [lindex $nodes $i]] {
lappend nodes $child
}
}
incr i
if {$i >= [llength $nodes]} {break}
}
return $open
}
# ------------------------------------------------------------------
# PROTECTED METHODS
# ------------------------------------------------------------------
# ----------------------------------------------------------------------
# PROTECTED METHOD: _drawLevel node indent
#
# Used internally by draw to draw one level of the hierarchy.
# Draws all of the nodes under node, using the indent string to
# indent nodes.
# ----------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::_drawLevel {node indent} {
lappend _markers "$node:start" [$itk_component(list) index insert]
set bg [$itk_component(list) cget -background]
#
# Obtain the list of subnodes for this node and cycle through
# each one displaying it in the hierarchy.
#
foreach child [_contents $node] {
set _images($child) "$itk_component(list).hicon[incr _hcounter]"
if {![info exists _states($child)]} {
set _states($child) $itk_option(-expanded)
}
#
# Check the user tags to see if they have been kind enough
# to tell us ahead of time what type of node we are dealing
# with branch or leaf. If they neglected to do so, then
# get the contents of the child node to see if it has children
# itself.
#
set display 0
if {[lsearch $_tags($child) leaf] != -1} {
set type leaf
} elseif {[lsearch $_tags($child) branch] != -1} {
set type branch
} else {
if {[llength [_contents $child]] == 0} {
set type leaf
} else {
set type branch
}
}
#
# Now that we know the type of node, branch or leaf, we know
# the type of icon to use.
#
if {$type == "leaf"} {
set icon $itk_option(-nodeicon)
eval $_filterCode
} else {
if {$_states($child)} {
set icon $itk_option(-openicon)
} else {
set icon $itk_option(-closedicon)
}
set display 1
}
#
# If display is set then we're going to be drawing this node.
# Save off the indentation level for this node and do the indent.
#
if {$display} {
set _indents($child) "$indent\t"
$itk_component(list) insert insert $indent
#
# Add the branch or leaf icon and setup a binding to toggle
# its expanded/collapsed state.
#
label $_images($child) -image $icon -background $bg
# DRH - enhanced and added features that handle image clicking,
# double clicking, and right clicking behavior
bind $_images($child) <ButtonPress-1> \
"[itcl::code $this toggle $child]; [itcl::code $this _imageSelect $child]"
bind $_images($child) <Double-1> [itcl::code $this _imageDblClick $child]
bind $_images($child) <ButtonPress-3> \
[itcl::code $this _imagePost $child $_images($child) $type %x %y]
$itk_component(list) window create insert -window $_images($child)
#
# If any user icons exist then draw them as well. The little
# regexp is just to check and see if they've passed in a
# command which needs to be evaluated as opposed to just
# a variable. Also, attach a binding to call them if their
# icon is selected.
#
if {[info exists _icons($child)]} {
foreach image $_icons($child) {
set wid "$itk_component(list).uicon[incr _ucounter]"
if {[regexp {\[.*\]} $image]} {
eval label $wid -image $image -background $bg
} else {
label $wid -image $image -background $bg
}
# DRH - this will bind events to the icons to allow
# clicking, double clicking, and right clicking actions.
bind $wid <ButtonPress-1> \
[itcl::code $this _iconSelect $child $image]
bind $wid <Double-1> \
[itcl::code $this _iconDblSelect $child $image]
bind $wid <ButtonPress-3> \
[itcl::code $this _imagePost $child $wid $type %x %y]
$itk_component(list) window create insert -window $wid
}
}
#
# Create the list of tags to be applied to the text. Start
# out with a tag of "info" and append "hilite" if the node
# is currently selected, finally add the tags given by the
# user.
#
set texttags [list "info" $child]
if {[info exists _selected($child)]} {
lappend texttags hilite
}
# The following conditional added for SF ticket #600941.
if {[info exists _marked($child)]} {
lappend texttags lowlite
}
foreach tag $_tags($child) {
lappend texttags $tag
}
#
# Insert the text for the node along with the tags and
# append to the markers the start of this node. The text
# has been broken at newlines into a list. We'll make sure
# that each line is at the same indentation position.
#
set firstline 1
foreach line $_text($child) {
if {$firstline} {
$itk_component(list) insert insert " "
} else {
$itk_component(list) insert insert "$indent\t"
}
$itk_component(list) insert insert $line $texttags "\n"
set firstline 0
}
$itk_component(list) tag raise $child
lappend _markers "$child:start" [$itk_component(list) index insert]
#
# If the state of the node is open, proceed to draw the next
# node below it in the hierarchy.
#
if {$_states($child)} {
_drawLevel $child "$indent\t"
}
}
}
lappend _markers "$node:end" [$itk_component(list) index insert]
}
# ----------------------------------------------------------------------
# PROTECTED METHOD: _contents uid
#
# Used internally to get the contents of a particular node. If this
# is the first time the node has been seen or the -alwaysquery
# option is set, the -querycommand code is executed to query the node
# list, and the list is stored until the next time it is needed.
#
# The querycommand may return not only the list of subnodes for the
# node but additional information on the tags and icons to be used.
# The return value must be parsed based on the number of elements in
# the list where the format is a list of lists:
#
# {{uid [text [tags [icons]]]} {uid [text [tags [icons]]]} ...}
# ----------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::_contents {uid} {
if {$itk_option(-alwaysquery)} {
} else {
if {[info exists _nodes($uid)]} {
return $_nodes($uid)
}
}
#
# Substitute any %n's for the node name whose children we're
# interested in obtaining.
#
set cmd $itk_option(-querycommand)
regsub -all {%n} $cmd [list $uid] cmd
set nodeinfolist [uplevel \#0 $cmd]
#
# Cycle through the node information returned by the query
# command determining if additional information such as text,
# user tags, or user icons have been provided. For text,
# break it into a list at any newline characters.
#
set _nodes($uid) {}
foreach nodeinfo $nodeinfolist {
set subnodeuid [lindex $nodeinfo 0]
lappend _nodes($uid) $subnodeuid
set llen [llength $nodeinfo]
if {$llen == 0 || $llen > 4} {
error "invalid number of elements returned by query\
command for node: \"$uid\",\
should be uid \[text \[tags \[icons\]\]\]"
}
if {$llen == 1} {
set _text($subnodeuid) [split $subnodeuid \n]
}
if {$llen > 1} {
set _text($subnodeuid) [split [lindex $nodeinfo 1] \n]
}
if {$llen > 2} {
set _tags($subnodeuid) [lindex $nodeinfo 2]
} else {
set _tags($subnodeuid) unknown
}
if {$llen > 3} {
set _icons($subnodeuid) [lindex $nodeinfo 3]
}
}
#
# Return the list of nodes.
#
return $_nodes($uid)
}
# ----------------------------------------------------------------------
# PROTECTED METHOD: _post x y
#
# Used internally to post the popup menu at the coordinate (x,y)
# relative to the widget. If (x,y) is on an item, then the itemMenu
# component is posted. Otherwise, the bgMenu is posted.
# ----------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::_post {x y} {
set rx [expr {[winfo rootx $itk_component(list)]+$x}]
set ry [expr {[winfo rooty $itk_component(list)]+$y}]
set index [$itk_component(list) index @$x,$y]
#
# The posted variable will hold the list of tags which exist at
# this x,y position that will be passed back to the user. They
# don't need to know about our internal tags, info, hilite, and
# lowlite, so remove them from the list.
#
set _posted {}
foreach tag [$itk_component(list) tag names $index] {
if {![_isInternalTag $tag]} {
lappend _posted $tag
}
}
#
# If we have tags then do the popup at this position.
#
if {$_posted != {}} {
# DRH - here is where the user's function for dynamic popup
# menu loading is done, if the user has specified to do so with the
# "-textmenuloadcommand"
if {$itk_option(-textmenuloadcommand) != {}} {
eval $itk_option(-textmenuloadcommand)
}
tk_popup $itk_component(itemMenu) $rx $ry
} else {
tk_popup $itk_component(bgMenu) $rx $ry
}
}
# ----------------------------------------------------------------------
# PROTECTED METHOD: _imagePost node image type x y
#
# Used internally to post the popup menu at the coordinate (x,y)
# relative to the widget. If (x,y) is on an image, then the itemMenu
# component is posted.
#
# Douglas R. Howard, Jr.
# ----------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::_imagePost {node image type x y} {
set rx [expr {[winfo rootx $image]+$x}]
set ry [expr {[winfo rooty $image]+$y}]
#
# The posted variable will hold the list of tags which exist at
# this x,y position that will be passed back to the user. They
# don't need to know about our internal tags, info, hilite, and
# lowlite, so remove them from the list.
#
set _posted {}
lappend _posted $node $type
#
# If we have tags then do the popup at this position.
#
if {$itk_option(-imagemenuloadcommand) != {}} {
eval $itk_option(-imagemenuloadcommand)
}
tk_popup $itk_component(itemMenu) $rx $ry
}
# ----------------------------------------------------------------------
# PROTECTED METHOD: _select x y
#
# Used internally to select an item at the coordinate (x,y) relative
# to the widget. The command associated with the -selectcommand
# option is execute following % character substitutions. If %n
# appears in the command, the selected node is substituted. If %s
# appears, a boolean value representing the current selection state
# will be substituted.
# ----------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::_select {x y} {
if {$itk_option(-selectcommand) != {}} {
if {[set seltags [$itk_component(list) tag names @$x,$y]] != {}} {
foreach tag $seltags {
if {![_isInternalTag $tag]} {
lappend node $tag
}
}
if {[lsearch $seltags "hilite"] == -1} {
set selectstatus 0
} else {
set selectstatus 1
}
set cmd $itk_option(-selectcommand)
regsub -all {%n} $cmd [lindex $node end] cmd
regsub -all {%s} $cmd [list $selectstatus] cmd
uplevel #0 $cmd
}
}
return
}
# ----------------------------------------------------------------------
# PROTECTED METHOD: _double x y
#
# Used internally to double click an item at the coordinate (x,y) relative
# to the widget. The command associated with the -dblclickcommand
# option is execute following % character substitutions. If %n
# appears in the command, the selected node is substituted. If %s
# appears, a boolean value representing the current selection state
# will be substituted.
#
# Douglas R. Howard, Jr.
# ----------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::_double {x y} {
if {$itk_option(-dblclickcommand) != {}} {
if {[set seltags [$itk_component(list) tag names @$x,$y]] != {}} {
foreach tag $seltags {
if {![_isInternalTag $tag]} {
lappend node $tag
}
}
if {[lsearch $seltags "hilite"] == -1} {
set selectstatus 0
} else {
set selectstatus 1
}
set cmd $itk_option(-dblclickcommand)
regsub -all {%n} $cmd [list $node] cmd
regsub -all {%s} $cmd [list $selectstatus] cmd
uplevel #0 $cmd
}
}
return
}
# ----------------------------------------------------------------------
# PROTECTED METHOD: _iconSelect node icon
#
# Used internally to upon selection of user icons. The -iconcommand
# is executed after substitution of the node for %n and icon for %i.
#
# Douglas R. Howard, Jr.
# ----------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::_iconSelect {node icon} {
set cmd $itk_option(-iconcommand)
regsub -all {%n} $cmd [list $node] cmd
regsub -all {%i} $cmd [list $icon] cmd
uplevel \#0 $cmd
return {}
}
# ----------------------------------------------------------------------
# PROTECTED METHOD: _iconDblSelect node icon
#
# Used internally to upon double selection of user icons. The
# -icondblcommand is executed after substitution of the node for %n and
# icon for %i.
#
# Douglas R. Howard, Jr.
# ----------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::_iconDblSelect {node icon} {
if {$itk_option(-icondblcommand) != {}} {
set cmd $itk_option(-icondblcommand)
regsub -all {%n} $cmd [list $node] cmd
regsub -all {%i} $cmd [list $icon] cmd
uplevel \#0 $cmd
}
return {}
}
# ----------------------------------------------------------------------
# PROTECTED METHOD: _imageSelect node icon
#
# Used internally to upon selection of user icons. The -imagecommand
# is executed after substitution of the node for %n.
#
# Douglas R. Howard, Jr.
# ----------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::_imageSelect {node} {
if {$itk_option(-imagecommand) != {}} {
set cmd $itk_option(-imagecommand)
regsub -all {%n} $cmd [list $node] cmd
uplevel \#0 $cmd
}
return {}
}
# ----------------------------------------------------------------------
# PROTECTED METHOD: _imageDblClick node
#
# Used internally to upon double selection of images. The
# -imagedblcommand is executed.
#
# Douglas R. Howard, Jr.
# ----------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::_imageDblClick {node} {
if {$itk_option(-imagedblcommand) != {}} {
set cmd $itk_option(-imagedblcommand)
regsub -all {%n} $cmd [list $node] cmd
uplevel \#0 $cmd
}
return {}
}
# ----------------------------------------------------------------------
# PROTECTED METHOD: _deselectSubNodes uid
#
# Used internally to recursively deselect all the nodes beneath a
# particular node.
# ----------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::_deselectSubNodes {uid} {
foreach node $_nodes($uid) {
if {[array names _selected $node] != {}} {
unset _selected($node)
}
if {[array names _nodes $node] != {}} {
_deselectSubNodes $node
}
}
}
# ----------------------------------------------------------------------
# PROTECTED METHOD: _deleteNodeInfo uid
#
# Used internally to recursively delete all the information about a
# node and its decendents.
# ----------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::_deleteNodeInfo {uid} {
#
# Recursively call ourseleves as we go down the hierarchy beneath
# this node.
#
if {[info exists _nodes($uid)]} {
foreach node $_nodes($uid) {
if {[array names _nodes $node] != {}} {
_deleteNodeInfo $node
}
}
}
#
# Unset any entries in our arrays for the node.
#
catch {unset _nodes($uid)}
catch {unset _text($uid)}
catch {unset _tags($uid)}
catch {unset _icons($uid)}
catch {unset _states($uid)}
catch {unset _images($uid)}
catch {unset _indents($uid)}
}
# ----------------------------------------------------------------------
# PROTECTED METHOD: _getParent uid
#
# Used internally to determine the parent for a node.
# ----------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::_getParent {uid} {
foreach node [array names _nodes] {
if {[set index [lsearch $_nodes($node) $uid]] != -1} {
return $node
}
}
}
# ----------------------------------------------------------------------
# PROTECTED METHOD: _getHeritage uid
#
# Used internally to determine the list of parents for a node.
# ----------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::_getHeritage {uid} {
set parents {}
if {[set parent [_getParent $uid]] != {}} {
lappend parents $parent
}
return $parents
}
# ----------------------------------------------------------------------
# PROTECTED METHOD (could be proc?): _isInternalTag tag
#
# Used internally to tags not to used for user callback commands
# ----------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::_isInternalTag {tag} {
set ii [expr {[lsearch -exact {info hilite lowlite unknown} $tag] != -1}];
return $ii;
}
# ----------------------------------------------------------------------
# PRIVATE METHOD: _configureTags
#
# This method added to fix SF ticket #596111. When the -querycommand
# is reset after initial construction, the text component loses its
# tag configuration. This method resets the hilite, lowlite, and info
# tags. csmith: 9/5/02
# ----------------------------------------------------------------------
itcl::body iwidgets::Hierarchy::_configureTags {} {
tag configure hilite -background $itk_option(-selectbackground) \
-foreground $itk_option(-selectforeground)
tag configure lowlite -background $itk_option(-markbackground) \
-foreground $itk_option(-markforeground)
tag configure info -font $itk_option(-font) -spacing1 6
}