#!/usr/bin/wish
#
# Heavily modified by Rick Macdonald <rickm@vsl.com> from the
# original by Richard Hipp.
#
# Copyright (C) 1997,1998 D. Richard Hipp
#
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# Library General Public License for more details.
#
# You should have received a copy of the GNU Library General Public
# License along with this library; if not, write to the
# Free Software Foundation, Inc., 59 Temple Place - Suite 330,
# Boston, MA 02111-1307, USA.
#
# Author contact information:
# drh@acm.org
# http://www.hwaci.com/drh/
#
# $Revision: 1.7 $
proc Tree:bindings {opt w x y {X {}} {Y {}}} {
global Trees
set tree $Trees($w)
upvar #0 $tree Tree
switch $opt {
1 {
set lbl [Tree:labelat $w $x $y]
eval Tree:setselection $w $lbl
# Have to set the highlight in case they click B1 before moving the mouse after a dropcmd.
set lbl [Tree:labelat $w $x $y]
eval Tree:sethighlight $w $lbl
#set Tree(curselection) $lbl
}
Double-1 {
eval Tree:open $w [Tree:labelat $w $x $y]
}
3 {
set lbl [Tree:labelat $w $x $y]
eval Tree:setselection $w $lbl
#set Tree(curselection) $lbl
if {[info exists Tree(contextcmd)] && [info procs [lindex $Tree(contextcmd) 0]] != ""} {
eval $Tree(contextcmd) {$w $lbl $X $Y}
}
}
B1-Motion {
if {!$Tree(dragndrop)} {
return
}
if {$Tree(dragActive) == 0} {
set v $Tree(highlight)
if {[info exists Tree(dragablecmd)] && [info procs [lindex $Tree(dragablecmd) 0]] != ""} {
if {![eval $Tree(dragablecmd) {$v}]} {
set Tree(dragActive) -1
set Tree(dragv) ""
return
}
}
set Tree(dragActive) 1
set Tree(dragv) $v
set Tree(B1-Motion_cursor) [lindex [$w config -cursor] 4]
$w config -cursor hand2
if {[string length $v] > 0 && [info exists Tree($v:tag)]} {
set bbox [$w bbox $Tree($v:tag)]
if {[llength $bbox] == 4} {
set Tree(dragwid) [expr {([lindex $bbox 2] - [lindex $bbox 0]) / 2}]
set Tree(draghig) [expr {([lindex $bbox 3] - [lindex $bbox 1]) / 2}]
}
}
}
if {$Tree(dragActive) < 0} {
return
}
if {[info exists Tree(dragidx)]} {
$w delete $Tree(dragidx)
}
if {[info exists Tree(dropablecmd)] && [info procs [lindex $Tree(dropablecmd) 0]] != ""} {
set lbl [Tree:labelat $w $x $y]
set v [eval Tree:joinnodes $w $lbl]
#puts "v=$v lbl=$lbl dragv=$Tree(dragv)"
set dropable [eval $Tree(dropablecmd) {$v}]
} {
set dropable 1
}
if {$dropable > 0} {
#puts "DROPABLE! lbl=$lbl dragv=$Tree(dragv)"
eval Tree:drawdroptarget $w $lbl
} {
Tree:drawdroptarget $w "" ""
}
if {$dropable >= 0} {
set Tree(dragidx) [$w create rectangle \
[expr {[$w canvasx $x] - $Tree(dragwid)}] \
[expr {[$w canvasy $y] - $Tree(draghig)}] \
[expr {[$w canvasx $x] + $Tree(dragwid)}] \
[expr {[$w canvasy $y] + $Tree(draghig)}] -outline blue]
}
}
B1-Release {
if {$Tree(dragActive) > 0} {
$w delete $Tree(dragidx)
$w config -cursor $Tree(B1-Motion_cursor)
if {[info exists Tree(dropcmd)] && [info procs [lindex $Tree(dropcmd) 0]] != "" && \
$Tree(droptarget) != ""} {
eval $Tree(dropcmd) {$w $Tree(dragv) $Tree(droptarget)}
}
Tree:drawdroptarget $w "" ""
set Tree(dragv) ""
}
set Tree(dragActive) 0
}
Motion {
set lbl [Tree:labelat $w $x $y]
eval Tree:sethighlight $w $lbl
if {[info exists Tree(fileinfocmd)] && [info procs [lindex $Tree(fileinfocmd) 0]] != ""} {
eval $Tree(fileinfocmd) {$lbl}
}
}
}
}
# Internal use only.
# Draw the tree on the canvas
proc Tree:build {w} {
global Trees
set tree $Trees($w)
upvar #0 $tree Tree
#puts [array get Tree]
$w delete all
catch {unset Tree(buildpending)}
set Tree(buildafter) idle
#set Tree(y) 30
set Tree(y) 8
#Tree:buildlayer $w $Tree(topdir) 10
Tree:buildlayer $w {} {} 4
$w config -scrollregion [$w bbox all]
Tree:drawselection $w
}
proc Tree:buildafter {w after} {
global Trees
set tree $Trees($w)
upvar #0 $tree Tree
set Tree(buildafter) $after
if {[info exists Tree(buildpending)]} {
# Run the script now.
set cmd [lindex [after info $Tree(buildpending)] 0]
after cancel $Tree(buildpending)
eval $cmd
} {
###set Tree(buildpending) [after $Tree(buildafter) "Tree:build $w"]
}
}
# Internal use only.
# Build a single layer of the tree on the canvas. Indent by $in pixels
proc Tree:buildlayer {w dir n in} {
global Trees
set tree $Trees($w)
upvar #0 $tree Tree
set v [Tree:joinnodes $w $dir $n]
if {$v == ""} {
set start $Tree(y)
} {
set start [expr $Tree(y)-10]
}
#puts "\nBUILDLAYER dir=$dir n=$n v=$v start=$start kids=$Tree($v:children)\n"
set y 0
set dirs ""
set files ""
set Tree($v:children) [lsort -$Tree($v:sortcmp) -$Tree($v:sortdir) $Tree($v:children)]
# This places all dirs before files in the tree
foreach c $Tree($v:children) {
set vc [Tree:joinnodes $w $v $c]
if {$Tree($vc:isdir)} {
lappend dirs $c
} {
lappend files $c
}
}
foreach c [concat $dirs $files] {
set vc [Tree:joinnodes $w $v $c]
#puts "\nBUILDLAYER-2 dir=$dir v=$n v=$v vc=$vc start=$start"
set y $Tree(y)
#TTD: make this dynamic according to font and icon size?
incr Tree(y) 17
$w create line $in $y [expr $in+10] $y -fill gray50
set icon $Tree($vc:icon)
set taglist x
foreach tag $Tree($vc:tags) {
lappend taglist $tag
}
set x [expr $in + 12]
set xinc 12
if {[string length $icon] > 0} {
set k [$w create image $x $y -image $icon -anchor w -tags $taglist]
#incr x 20
set iwidth [image width $icon]
incr x [expr $iwidth + 4]
incr xinc [expr $iwidth / 2]
set Tree(tag:$k) [list $v $c]
}
set text $c
set j [$w create text $x $y -text $text -font $Tree(font) -anchor w -tags $taglist]
set Tree(tag:$j) [list $v $c]
set Tree($vc:tag) $j
if {$Tree($vc:isdir) > 0} {
#puts "builddir1 Tree($vc:open)=$Tree($vc:open) Tree($vc:children)=$Tree($vc:children)"
if {[string length $Tree($vc:children)] && $Tree($vc:open)} {
set j [$w create image $in $y -image Tree:openbm]
#$w bind $j <1> "set Tree($vc:open) 0; Tree:build $w"
$w bind $j <1> "Tree:close $w \"$v\" \"$c\""
#Tree:buildlayer $w $v $c [expr $in+18]
Tree:buildlayer $w $v $c [expr $in+$xinc]
} {
if {!($Tree(colapseEmptyDirs) && ![string length $Tree($vc:children)])} {
set j [$w create image $in $y -image Tree:closedbm]
#$w bind $j <1> "set Tree($vc:open) 1; Tree:build $w"
$w bind $j <1> "Tree:open $w \"$v\" \"$c\""
set Tree($vc:isdir) $j
}
}
}
}
set j [$w create line $in $start $in [expr $y + 1] -fill gray50]
$w lower $j
}
# Internal use only
# Call Tree:build then next time we're idle
proc Tree:buildwhenidle {w} {
global Trees
set tree $Trees($w)
upvar #0 $tree Tree
if {![info exists Tree(buildpending)]} {
set Tree(buildpending) [after $Tree(buildafter) "Tree:build $w"]
}
}
proc Tree:close {w dir n} {
global Trees
set tree $Trees($w)
upvar #0 $tree Tree
set v [Tree:joinnodes $w $dir $n]
if {[info exists Tree($v:open)] && $Tree($v:open) == 1} {
set Tree($v:open) 0
Tree:build $w
}
}
#
# Pass configuration options to the tree (canvas) widget
#
proc Tree:config {w args} {
global Trees
set tree $Trees($w)
upvar #0 $tree Tree
eval $w config $args
}
#
# Create a new tree widget. $args become the configuration arguments to
# the canvas widget from which the tree is constructed.
#
proc Tree:create {w tree joinchar args} {
global Trees
set Trees($w) $tree
set Trees($tree) $w
upvar #0 $tree Tree
global tcl_platform
switch $tcl_platform(platform) {
unix {
set Tree(font) \
-adobe-helvetica-medium-r-normal-*-11-80-100-100-p-56-iso8859-1
}
windows {
set Tree(font) \
-adobe-helvetica-medium-r-normal-*-14-100-100-100-p-76-iso8859-1
}
}
if {![winfo exists $w]} {
eval canvas $w -bg white $args
}
# TTD: do we need or want this binding?
### bind $w <Destroy> "Tree:deltree $w"
set Tree(topdir) [list {} {}]
set v {}
# Tree:dfltconfig $w {} {}
set Tree(joinchar) $joinchar
set Tree(curselection) [list {} {}]
set Tree(colapseEmptyDirs) 0
set Tree(PointerInCanvas) 0
set Tree(dragndrop) 0
set Tree(dragActive) 0
set Tree(dragv) {}
set Tree($v:children) {}
set Tree($v:open) 0
set Tree($v:isdir) 0
set Tree($v:icon) {}
set Tree($v:tags) {}
# Tree:buildwhenidle $w
set Tree(buildafter) idle
set Tree(highlight) {}
set Tree(hilidx) {}
set Tree(selection) {}
set Tree(selidx) {}
set Tree(dropidx) {}
bind $w <1> "Tree:bindings 1 %W %x %y"
bind $w <Double-1> "Tree:bindings Double-1 %W %x %y"
bind $w <3> "Tree:bindings 3 %W %x %y %X %Y"
bind $w <Motion> "Tree:bindings Motion %W %x %y"
bind $w <B1-Motion> "Tree:bindings B1-Motion %W %x %y %X %Y"
bind $w <ButtonRelease-1> "Tree:bindings B1-Release %W %x %y"
if {![info exists Tree(init)]} {
Tree:init
}
}
#
# Delete element $n from $dir in the tree $w.
#
proc Tree:delitem {w dir n} {
global Trees
if {![info exists Trees($w)]} {
return
}
set tree $Trees($w)
upvar #0 $tree Tree
set v [Tree:joinnodes $w $dir $n]
#puts "del: dir=$dir n=$n v=$v"
if {![info exists Tree($v:open)]} return
foreach c $Tree($v:children) {
catch {Tree:delitem $w $v $c}
}
foreach var [array names Tree $v:*] {
unset Tree($var)
}
set i [lsearch -exact $Tree($dir:children) $n]
if {$i>=0} {
set Tree($dir:children) [lreplace $Tree($dir:children) $i $i]
}
if {$Tree($dir:children) == {}} {
# This dir is now empty, so mark it closed.
#puts "MARKING CLOSED: $dir"
set Tree($dir:open) 0
}
Tree:buildwhenidle $w
}
#
# Delete the entire tree.
#
proc Tree:deltree {w} {
global Trees
if {![info exists Trees($w)]} {
return
}
set tree $Trees($w)
upvar #0 $tree Tree
catch {unset Tree}
catch {unset Trees($w)}
}
# Initialize an element of the tree.
# Internal use only
#
proc Tree:dfltconfig {w dir n} {
global Trees
set tree $Trees($w)
upvar #0 $tree Tree
set v [Tree:joinnodes $w $dir $n]
set Tree($v:children) {}
set Tree($v:open) 0
set Tree($v:isdir) 0
set Tree($v:icon) {}
set Tree($v:tags) {}
}
# Internal use only.
# Draw the position highlight
proc Tree:drawhighlight {w} {
global Trees
set tree $Trees($w)
upvar #0 $tree Tree
if {[string length $Tree(hilidx)]} {
$w delete $Tree(hilidx)
}
set v $Tree(highlight)
if {[string length $v] == 0} return
if {![info exists Tree($v:tag)]} return
set bbox [$w bbox $Tree($v:tag)]
if {[llength $bbox] == 4} {
set i [eval $w create rectangle $bbox -outline grey70]
set Tree(hilidx) $i
#$w lower $i
} else {
set Tree(hilidx) {}
}
}
# Internal use only.
# Draw the drop target highlight
proc Tree:drawdroptarget {w dir n} {
global Trees
set tree $Trees($w)
upvar #0 $tree Tree
set v [Tree:joinnodes $w $dir $n]
if {[string length $Tree(dropidx)]} {
$w delete $Tree(dropidx)
}
set Tree(droptarget) {}
set Tree(dropidx) {}
if {[string length $v] == 0} return
if {![info exists Tree($v:tag)]} return
set bbox [$w bbox $Tree($v:tag)]
if {[llength $bbox] == 4} {
set i [eval $w create rectangle $bbox -fill skyblue -outline {{}}]
set Tree(dropidx) $i
$w lower $i
set Tree(droptarget) [list $dir $n]
}
}
# Draw the selection highlight
proc Tree:drawselection {w} {
global Trees
set tree $Trees($w)
upvar #0 $tree Tree
if {[string length $Tree(selidx)]} {
$w delete $Tree(selidx)
}
set Tree(selidx) {}
set v $Tree(selection)
if {[string length $v] == 0} return
if {![info exists Tree($v:tag)]} return
set bbox [$w bbox $Tree($v:tag)]
if {[llength $bbox] == 4} {
set i [eval $w create rectangle $bbox -fill skyblue -outline {{}}]
set Tree(selidx) $i
$w lower $i
}
}
#
# Retrieve the current selection
#
proc Tree:getselection {w} {
global Trees
set tree $Trees($w)
upvar #0 $tree Tree
return $Tree(selection)
}
proc Tree:init {} {
global Trees
option add *highlightThickness 0
image create photo idir -data {
R0lGODdhEAAQAPIAAAAAAHh4eLi4uPj4APj4+P///wAAAAAAACwAAAAAEAAQAAADPVi63P4w
LkKCtTTnUsXwQqBtAfh910UU4ugGAEucpgnLNY3Gop7folwNOBOeiEYQ0acDpp6pGAFArVqt
hQQAO///
}
image create photo ifile -data {
R0lGODdhEAAQAPIAAAAAAHh4eLi4uPj4+P///wAAAAAAAAAAACwAAAAAEAAQAAADPkixzPOD
yADrWE8qC8WN0+BZAmBq1GMOqwigXFXCrGk/cxjjr27fLtout6n9eMIYMTXsFZsogXRKJf6u
P0kCADv/
}
#
# Bitmaps used to show which parts of the tree can be opened.
#
set maskdata "#define solid_width 9\n#define solid_height 9"
append maskdata {
static unsigned char solid_bits[] = {
0xff, 0x01, 0xff, 0x01, 0xff, 0x01, 0xff, 0x01, 0xff, 0x01, 0xff, 0x01,
0xff, 0x01, 0xff, 0x01, 0xff, 0x01
};
}
set data "#define open_width 9\n#define open_height 9"
append data {
static unsigned char open_bits[] = {
0xff, 0x01, 0x01, 0x01, 0x01, 0x01, 0x01, 0x01, 0x7d, 0x01, 0x01, 0x01,
0x01, 0x01, 0x01, 0x01, 0xff, 0x01
};
}
image create bitmap Tree:openbm -data $data -maskdata $maskdata \
-foreground black -background white
set data "#define closed_width 9\n#define closed_height 9"
append data {
static unsigned char closed_bits[] = {
0xff, 0x01, 0x01, 0x01, 0x11, 0x01, 0x11, 0x01, 0x7d, 0x01, 0x11, 0x01,
0x11, 0x01, 0x01, 0x01, 0xff, 0x01
};
}
image create bitmap Tree:closedbm -data $data -maskdata $maskdata \
-foreground black -background white
set Trees(init) 1
}
proc Tree:joinnodes {w dir n} {
global Trees
set tree $Trees($w)
upvar #0 $tree Tree
if {$dir == ""} {
set v $n
} {
set v $dir$Tree(joinchar)$n
}
return $v
}
#
# Return the full pathname of the label for widget $w that is located
# at real coordinates $x, $y
#
proc Tree:labelat {w x y} {
global Trees
set tree $Trees($w)
upvar #0 $tree Tree
#set x [$w canvasx $x]
set x [winfo width $w]
set y [$w canvasy $y]
#foreach m [$w find overlapping 0 $y $x $y]
#TTD: make the +/- 1 dynamic according to font and icon size?
foreach m [$w find overlapping 0 [expr $y - 1] $x [expr $y + 1]] {
if {[info exists Tree(tag:$m)]} {
return $Tree(tag:$m)
}
}
return [list "" ""]
}
proc Tree:labelatXXX {w x y} {
global Trees
set tree $Trees($w)
upvar #0 $tree Tree
set x [$w canvasx $x]
set y [$w canvasy $y]
#foreach m [$w find overlapping $x $y $x $y]
foreach m [$w find overlapping $x [expr $y - 5] $x [expr $y + 5]] {
if {[info exists Tree(tag:$m)]} {
return $Tree(tag:$m)
}
}
return ""
}
#
# Insert a new element $v into the tree $w.
#
proc Tree:newitem {w dir n args} {
global Trees
set tree $Trees($w)
upvar #0 $tree Tree
set v [Tree:joinnodes $w $dir $n]
#puts Tree=[array get Tree]
#puts "new: dir=$dir n=$n v=$v args=$args"
if {![info exists Tree($dir:open)]} {
#puts "open=[array get Tree *open]"
error "Tree: parent item \"$dir\" is missing."
}
set i [lsearch -exact $Tree($dir:children) $n]
if {$i>=0} {
error "Tree: item \"$n\" already exists in parent \"$dir\"."
}
Tree:dfltconfig $w $dir $n
set sortcmp ascii
set sortdir increasing
foreach {op arg} $args {
switch -exact -- $op {
-image {set Tree($v:icon) $arg}
-tags {set Tree($v:tags) $arg}
-type {set Tree($v:isdir) [string match "dir" $arg]}
-sortdic {if {$arg} {set sortcmp dictionary} {set sortcmp ascii}}
-sortdir {set sortdir $arg}
}
}
# The children are sorted at build time.
set Tree($dir:sortcmp) $sortcmp
set Tree($dir:sortdir) $sortdir
lappend Tree($dir:children) $n
if {$Tree($dir:isdir) < 0} {
# This dir is no longer empty.
set Tree($dir:isdir) 1
}
Tree:buildwhenidle $w
}
# Open a branch of a tree
#
proc Tree:open {w dir n} {
global Trees
set tree $Trees($w)
upvar #0 $tree Tree
set v [Tree:joinnodes $w $dir $n]
#puts "tree:open: dir=$dir n=$n v=$v array=[array get Tree $v:*]"
if {!$Tree($v:isdir)} {
return
}
if {[info exists Tree(opencmd)] && [info procs $Tree(opencmd)] != ""} {
eval $Tree(opencmd) {$w $dir $n}
}
if {[info exists Tree($v:open)]} {
if {$Tree($v:open) == 0} {
if {[info exists Tree($v:children)] && [string length $Tree($v:children)] > 0} {
set Tree($v:open) 1
#Tree:build $w
Tree:buildwhenidle $w
} {
# Empty directory
$w delete $Tree($v:isdir)
set Tree($v:isdir) -1
}
} {
Tree:close $w $dir $n
}
}
}
#
# Change the selection to the indicated item
#
proc Tree:sethighlight {w dir n} {
global Trees
set tree $Trees($w)
upvar #0 $tree Tree
set v [Tree:joinnodes $w $dir $n]
set Tree(highlight) $v
Tree:drawhighlight $w
}
#
# Change the selection to the indicated item
#
proc Tree:setselection {w dir n} {
global Trees
set tree $Trees($w)
upvar #0 $tree Tree
set v [Tree:joinnodes $w $dir $n]
set Tree(selection) $v
set Tree(curselection) [list $dir $n]
Tree:drawselection $w
}