You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
1984 lines
65 KiB
Plaintext
1984 lines
65 KiB
Plaintext
15 years ago
|
# 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
|
||
|
|
}
|