]> www.wagner.pp.ru Git - oss/fgis.git/blob - tcl/hierarchy.tcl
The second attempt to automate building :-) A lot of work here should be
[oss/fgis.git] / tcl / hierarchy.tcl
1 ##
2 ## hierarchy.tcl
3 ## Hierarchical Display Widget
4 ##
5 ## Layout routines taken from oooold code, author unkown.
6 ## Copyright 1995-1997 Jeffrey Hobbs
7 ##
8 ## jhobbs@cs.uoregon.edu, http://www.cs.uoregon.edu/~jhobbs/
9 ##
10 ## source standard_disclaimer.tcl
11 ## source beer_ware.tcl
12 ##
13 ## Last Update: 28 June 1997
14
15 ##-----------------------------------------------------------------------
16 ## PROCEDURE(S)
17 ##      hierarchy, hierarchy_dir, hierarchy_widget
18 ##
19 ## ARGUMENTS && DESCRIPTION
20 ##
21 ## hierarchy <window pathname> <options>
22 ##      Implements a hierarchical listbox
23 ## hierarchy_dir <window pathname> <options>
24 ##      Implements a hierarchical listbox using a directory view structure
25 ##      for the default methods
26 ## hierarchy_widget <window pathname> <options>
27 ##      Implements a hierarchical listbox using a widget view structure
28 ##      for the default methods
29 ##
30 ## OPTIONS
31 ##      (Any canvas option may be used with a hierarchy)
32 ##
33 ## -autoscrollbar TCL_BOOLEAN                   DEFAULT: 1
34 ##      Determines whether scrollbars automagically pop-up or
35 ##      are permanently there.
36 ##
37 ## -browsecmd procedure                         DEFAULT: noop
38 ##      A command which the widget will execute when the node is expanded
39 ##      to retrieve the children of a node.  The widget and node path are
40 ##      appended to the command as a list of node names which
41 ##      form a path to the node from the root.  Thus the first
42 ##      element of this list will always be the root node.
43 ##
44 ## -command procedure                           DEFAULT: noop
45 ##      A command which the widget will execute when the node is toggled.
46 ##      The name of the widget, the node path, and whether the children of
47 ##      the node are showing (0/1) is appended to the procedure args.
48 ##
49 ## -common TCL_BOOLEAN                          DEFAULT: 0
50 ##      If this is true, when a node gets added to the selection,
51 ##      all other nodes with the same *name* (regardless of
52 ##      the path to the node) get selected as well.  The selection
53 ##      is reported only as a set of node names, not a set of node 
54 ##      paths.  Thus selection acts like an equivalence over nodes
55 ##      of the same name.  Useful only in hierarchies where some
56 ##      nodes in the hierarchy really refer to the same logical object.
57 ##      NOTE: FEATURE NOT YET IMPLEMENTED
58 ##
59 ## -decoration TCL_BOOLEAN                      DEFAULT: 1
60 ##      If this is true, the "tree" lines are drawn.
61 ##
62 ## -expand #                                    DEFAULT: 1
63 ##      an integer value for an initial depth to expand to.
64 ##
65 ## -font fontname                               DEFAULT: fixed
66 ##      The default font used for the text.
67 ##
68 ## -foreground color                            DEFAULT: black
69 ##      The default foreground color used for text of unselected nodes.
70 ##
71 ## -ipad #                                      DEFAULT: 3
72 ##      The internal space added between the image and the text for a
73 ##      given node.
74 ##
75 ## -nodelook procedure                          DEFAULT: noop
76 ##      A command the widget will execute to get the look of a node.
77 ##      The node is appended to the command as a list of
78 ##      node-names which form a path to the node from the root.
79 ##      Thus the first element of this list will always be the
80 ##      root node.  Also appended is a 
81 ##      boolean value which indicates whether the node's children
82 ##      are currently displayed.  This allows the node's
83 ##      look to change if it is "opened" or "closed".
84 ##
85 ##      This command must return a 4-tuple list containing:
86 ##              0. the text to display at the node
87 ##              1. the font to use for the text
88 ##              2. an image to display
89 ##              3. the foreground color to use for the node
90 ##      If no font (ie. {}) is specified then
91 ##      the value from -font is used.  If no image is specified
92 ##      then no image is displayed.
93 ##      The default is a command to which produces a nice look
94 ##      for a file manager.  
95 ##
96 ## -paddepth #                                  DEFAULT: 12
97 ##      The indent space added for child branches.
98 ##
99 ## -padstack #                                  DEFAULT: 2
100 ##      The space added between two rows
101 ##
102 ## -root rootname                               DEFAULT: {}
103 ##      The name of the root node of the tree.  Each node
104 ##      name must be unique amongst the children of each node.
105 ##
106 ## -selectbackground color                      DEFAULT: red
107 ##      The default background color used for the text of selected nodes.
108 ##
109 ## -selectmode (single|browse|multiple)         DEFAULT: browse
110 ##      Like listbox modes, "multiple" is a mix of multiple && extended.
111 ##
112 ## -showall TCL_BOOLEAN                         DEFAULT: 0
113 ##      For directory nodelook, also show Unix '.' (hidden) files/dirs.
114 ##
115 ## -showfiles TCL_BOOLEAN                       DEFAULT: 0
116 ##      Show files as well as directories.
117 ##
118 ## -showparent string                           DEFAULT: {}
119 ##      For hierarchy_dir nodelook, if string != {}, then it will show that
120 ##      string which will reset the root node to its parent.
121 ##
122 ## RETURNS: The window pathname
123 ##
124 ## METHODS
125 ##      These are the methods that the hierachical listbox object recognizes.
126 ##      (ie - hierachy .h ; .h <method> <args>)
127 ##      Any unique substring is acceptable
128 ##
129 ## configure ?option? ?value option value ...?
130 ## cget option
131 ##      Standard tk widget routines.
132 ##
133 ## close index
134 ##      Closes the specified index (will trigger -command).
135 ##
136 ## curselection
137 ##      Returns the indices of the selected items.  This differs from the
138 ##      listbox method because indices here have no implied order.
139 ##
140 ## get index ?index ...?
141 ##      Returns the node paths of the items referenced.  Ranges are not
142 ##      allowed.  Index specification is like that allowed by the index
143 ##      method.
144 ##
145 ## qget index ?index ...?
146 ##      As above, but the indices must be that of the item (as returned
147 ##      by the index or curselection method).
148 ##
149 ## index index
150 ##      Returns the hierarchy numerical index of the item (the numerical
151 ##      index has no implied order relative to the list items).  index
152 ##      may be of the form:
153 ##
154 ##      number - Specifies the element as a numerical index.
155 ##      root   - specifies the root item.
156 ##      string - Specifis an item that has that text in it's node.
157 ##      @x,y   - Indicates the element that covers the point in
158 ##              the listbox window specified by x and y (in pixel
159 ##              coordinates).  If no element covers that point,
160 ##              then the closest element to that point is used.
161 ##
162 ## open index
163 ##      Opens the specified index (will trigger -command).
164 ##
165 ## see index
166 ##      Ensures that the item specified by the index is viewable.
167 ##
168 ## selection option arg
169 ##      This works like the listbox selection method with the following
170 ##      exceptions:
171 ##
172 ##      The selection clear option can take multiple indices, but not a range.
173 ##      No arguments to clear means clear all the selected elements.
174 ##
175 ##      The selection set option can take multiple indices, but not a range.
176 ##      The key word 'all' sets the selection for all elements.
177 ##
178 ## size
179 ##      Returns the number of items in the hierarchical listbox.
180 ##
181 ## toggle index
182 ##      Toggles (open or closed) the item specified by index
183 ##      (triggers -command).
184 ##
185 ## BINDINGS
186 ##      Most Button-1 bindings on the hierarchy work in the same manner
187 ##      as those for the listbox widget, as defined by the selectmode.
188 ##      Those that vary are listed below:
189 ##
190 ## <Double-Button-1>
191 ##      Toggles a node in the hierarchy
192 ##
193 ## NAMESPACE & STATE
194 ##      The megawidget creates a global array with the classname, and a
195 ## global array which is the name of each megawidget created.  The latter
196 ## array is deleted when the megawidget is destroyed.
197 ##      The procedure hierarchy and those beginning with Hierarchy are
198 ## used.  Also, when a widget is created, commands named .$widgetname
199 ## and Hierarchy$widgetname are created.
200 ##
201 ## Cryptic source code arguments explained:
202 ## np   == node path
203 ## cnp  == changed np
204 ## knp  == kids np
205 ## xcnp == extra cnp
206 ##-----------------------------------------------------------------------
207
208 package require Widget 1.0
209 package provide Hierarchy 1.11
210
211 ## Create the Hiearchy megawidget class definition
212 ##
213 ## In general, we cannot use $data(basecmd) in the construction, but the
214 ## scrollbar commands won't be called until after it really exists as a
215 ## proper command
216 array set Hierarchy {
217     type                frame
218     base                {canvas canvas canvas {-relief sunken -bd 1 \
219             -highlightthickness 1 \
220             -yscrollcommand [list $data(yscrollbar) set] \
221             -xscrollcommand [list $data(xscrollbar) set]}}
222     components          {
223         {scrollbar xscrollbar sx {-orient h -bd 1 -highlightthickness 1\
224                 -command [list $data(basecmd) xview]}}
225         {scrollbar yscrollbar sy {-orient v -bd 1 -highlightthickness 1\
226                 -command [list $data(basecmd) yview]}}
227     }
228
229     -autoscrollbar      {autoScrollbar  AutoScrollbar   1}
230     -browsecmd          {browseCmd      BrowseCmd       {}}
231     -command            {command        Command         {}}
232     -decoration         {decoration     Decoration      1}
233     -expand             {expand         Expand          1}
234     -font               {font           Font            fixed}
235     -foreground         {foreground     Foreground      black}
236     -ipad               {ipad           Ipad            3}
237     -nodelook           {nodeLook       NodeLook        {}}
238     -paddepth           {padDepth       PadDepth        12}
239     -padstack           {padStack       PadStack        2}
240     -root               {root           Root            {}}
241     -selectmode         {selectMode     SelectMode      browse}
242     -selectbackground   {selectBackground SelectBackground red}
243     -state              {state          State           normal}
244
245     -showall            {showAll        ShowAll         0}
246     -showparent         {showParent     ShowParent      {}}
247     -showfiles          {showFiles      ShowFiles       0}
248 }
249 # Create this to make sure there are registered in auto_mkindex
250 # these must come before the [widget create ...]
251 proc Hierarchy args {}
252 proc hierarchy args {}
253 widget create Hierarchy
254
255 proc hierarchy_dir {w args} {
256     uplevel hierarchy $w -root [list [pwd]] \
257             -nodelook   Hierarchy:FileLook \
258             -command    Hierarchy:FileActivate \
259             -browsecmd  Hierarchy:FileList \
260             $args
261 }
262
263 proc hierarchy_widget {w args} {
264     uplevel hierarchy $w -root . \
265             -nodelook   Hierarchy:WidgetLook \
266             -command    Hierarchy:WidgetActivate \
267             -browsecmd  Hierarchy:WidgetList \
268             $args
269 }
270
271 ;proc Hierarchy:construct { w } {
272     upvar \#0 $w data
273
274     ## Private variables
275     array set data [list \
276             hasnodelook 0 \
277             halfpstk    [expr $data(-padstack)/2] \
278             width       400 \
279             ]
280
281     grid $data(canvas) $data(yscrollbar) -sticky news
282     grid $data(xscrollbar) -sticky ew
283     grid columnconfig $w 0 -weight 1
284     grid rowconfig $w 0 -weight 1
285     bind $data(canvas) <Configure> [list Hierarchy:Resize $w %w %h]
286 }
287
288 ;proc Hierarchy:init { w } {
289     upvar \#0 $w data
290
291     set data(:$data(-root),showkids) 0
292     Hierarchy:ExpandNodeN $w $data(-root) $data(-expand)
293     if {[catch {$w see $data(-root)}]} {
294         $data(basecmd) configure -scrollregion "0 0 1 1"
295     }
296 }
297
298 ;proc Hierarchy:configure {w args} {
299     upvar \#0 $w data
300
301     set truth {^(1|yes|true|on)$}
302     set resize 0
303     foreach {key val} $args {
304         switch -- $key {
305             -autoscrollbar {
306                 set val [regexp -nocase $truth $val]
307                 if {$val} {
308                     set resize 1
309                 } else {
310                     grid $data(xscrollbar)
311                     grid $data(yscrollbar)
312                 }
313             }
314             -decoration { set val [regexp -nocase $truth $val] }
315             -padstack   { set data(halfpstk) [expr $val/2] }
316             -nodelook   {
317                 ## We set this special bool val because it saves some
318                 ## computation in ExpandNode, a deeply nested proc
319                 set data(hasnodelook) [string compare $val {}]
320             }
321             -root               {
322                 if {[info exists data(:$data(-root),showkids)]} {
323                     ## All data about items and selection should be
324                     ## cleared and the items deleted
325                     foreach name [concat [array names data :*] \
326                             [array names data S,*]] {unset data($name)}
327                     $data(basecmd) delete all
328                     set data(-root) $val
329                     set data(:$val,showkids) 0
330                     Hierarchy:ExpandNodeN $w $val $data(-expand)
331                     ## We can reset resize because ExpandNodeN forces it
332                     set resize 0
333                     continue
334                 }
335             }
336             -selectbackground {
337                 foreach i [array names data S,*] {
338                     $data(basecmd) itemconfigure [string range $i 2 end] \
339                             -fill $val
340                 }
341             }
342             -state      {
343                 if {![regexp {^(normal|disabled)$} $val junk val]} {
344                     return -code error "bad state value \"$val\":\
345                             must be normal or disabled"
346                 }
347             }
348             -showall    -
349             -showfiles  {
350                 set val [regexp -nocase $truth $val]
351                 if {$val == $data($key)} continue
352                 if {[info exists data(:$data(-root),showkids)]} {
353                     foreach i [array names data :*,kids] { unset data($i) }
354                     foreach i [array names data :*,showkids] {
355                         ## FIX - this doesn't really work dynamically
356                         if {$data($i)} {
357                             ## probably requires a call to Hierarchy:Redraw
358                         }
359                     }
360                 }
361             }
362         }
363         set data($key) $val
364     }
365     if {$resize} {
366         Hierarchy:Resize $w [winfo width $data(canvas)] \
367                 [winfo height $data(canvas)]
368     }
369 }
370
371 ;proc Hierarchy_index { w idx } {
372     upvar \#0 $w data
373     set c $data(basecmd)
374     if {[string match all $idx]} {
375         return [$c find withtag box]
376     } elseif {[regexp {^(root|anchor)$} $idx]} {
377         return [$c find withtag box:$data(-root)]
378     }
379     foreach i [$c find withtag $idx] {
380         if {[string match rec* [$c type $i]]} { return $i }
381     }
382     if {[regexp {@(-?[0-9]+),(-?[0-9]+)} $idx z x y]} {
383         return [$c find closest [$w canvasx $x] [$w canvasy $y] 1 text]
384     }
385     foreach i [$c find withtag box:[lindex $idx 0]] { return $i }
386     return -code error "bad hierarchy index \"$idx\":\
387             must be current, @x,y, a number, or a node name"
388 }
389
390 ;proc Hierarchy_selection { w args } {
391     if {[string match {} $args]} {
392         return -code error \
393                 "wrong \# args: should be \"$w selection option args\""
394     }
395     upvar \#0 $w data
396     set err [catch {Hierarchy_index $w [lindex $args 1]} idx]
397     switch -glob -- [lindex $args 0] {
398         an* {
399             ## anchor
400             ## stubbed out - too complicated to support
401         }
402         cl* {
403             ## clear
404             set c $data(basecmd)
405             if {$err} {
406                 foreach arg [array names data S,*] { unset data($arg) }
407                 $c itemconfig box -fill {}
408             } else {
409                 catch {unset data(S,$idx)}
410                 $c itemconfig $idx -fill {}
411                 foreach idx [lrange $args 2 end] {
412                     if {[catch {Hierarchy_index $w $idx} idx]} {
413                         catch {unset data(S,$idx)}
414                         $c itemconfig $idx -fill {}
415                     }
416                 }
417             }
418         }
419         in* {
420             ## includes
421             if {$err} {
422                 if {[llength $args]==2} {
423                     return -code error $idx
424                 } else {
425                     return -code error "wrong \# args:\
426                             should be \"$w selection includes index\""
427                 }
428             }
429             return [info exists data(S,$idx)]
430         }
431         se* {
432             ## set
433             if {$err} {
434                 if {[string compare {} $args]} return
435                 return -code error "wrong \# args:\
436                         should be \"$w selection set index ?index ...?\""
437             } else {
438                 set c $data(basecmd); set col $data(-selectbackground)
439                 if {[string match all [lindex $args 1]]} {
440                     foreach i $idx { set data(S,$i) 1 }
441                     $c itemconfig box -fill $col
442                 } else {
443                     set data(S,$idx) 1
444                     $c itemconfig $idx -fill $col
445                     foreach idx [lrange $args 2 end] {
446                         if {![catch {Hierarchy_index $w $idx} idx]} {
447                             set data(S,$idx) 1
448                             $c itemconfig $idx -fill $col
449                         }
450                     }
451                 }
452             }
453         }
454         default {
455             return -code error "bad selection option \"[lindex $args 0]\":\
456                     must be clear, includes, set"
457         }
458     }
459 }
460
461 ;proc Hierarchy_curselection {w} {
462     upvar \#0 $w data
463
464     set res {}
465     foreach i [array names data S,*] { lappend res [string range $i 2 end] }
466     return $res
467 }
468
469 ;proc Hierarchy_get {w args} {
470     upvar \#0 $w data
471
472     set nps {}
473     foreach arg $args {
474         if {![catch {Hierarchy_index $w $arg} idx] && \
475                 [string compare {} $idx]} {
476             set tags [$data(basecmd) gettags $idx]
477             if {[set i [lsearch -glob $tags box:*]]>-1} {
478                 lappend nps [string range [lindex $tags $i] 4 end]
479             }
480         }
481     }
482     return $nps
483 }
484
485 ;proc Hierarchy_qget {w args} {
486     upvar \#0 $w data
487
488     ## Quick get.  Avoids expensive Hierarchy_index call
489     set nps {}
490     foreach arg $args {
491         set tags [$data(basecmd) itemcget $arg -tags]
492         if {[set i [lsearch -glob $tags box:*]]>-1} {
493             lappend nps [string range [lindex $tags $i] 4 end]
494         }
495     }
496     return $nps
497 }
498
499 ;proc Hierarchy_see {w args} {
500     upvar \#0 $w data
501
502     if {[catch {Hierarchy_index $w $args} idx]} {
503         return -code error $idx
504     } elseif {[string compare {} $idx]} {
505         set c $data(basecmd)
506         foreach {x y x1 y1} [$c bbox $idx] {top btm} [$c yview] {
507             set stk [lindex [$c cget -scrollregion] 3]
508             set pos [expr (($y1+$y)/2.0)/$stk - ($btm-$top)/2.0]
509         }
510         $c yview moveto $pos
511     }
512 }
513
514 ;proc Hierarchy_size {w} {
515     upvar \#0 $w data
516     return [llength [$data(basecmd) find withtag box]]
517 }
518
519 ## This will be the one called by <Double-Button-1> on the canvas,
520 ## if -state is normal, so we have to make sure that $w is correct.
521 ##
522 ;proc Hierarchy_toggle { w index } {
523     Hierarchy:toggle $w $index toggle
524 }
525
526 ;proc Hierarchy_close { w index } {
527     Hierarchy:toggle $w $index close
528 }
529
530 ;proc Hierarchy_open { w index } {
531     Hierarchy:toggle $w $index open
532 }
533
534 ;proc Hierarchy:toggle { w index which } {
535     if {[string compare Hierarchy [winfo class $w]]} {
536         set w [winfo parent $w]
537     }
538     upvar \#0 $w data
539
540     if {[string match {} [set np [$w get $index]]]} return
541     set np [lindex $np 0]
542
543     set old [$data(basecmd) cget -cursor]
544     $data(basecmd) config -cursor watch
545     update
546     switch $which {
547         close   { Hierarchy:CollapseNodeAll $w $np }
548         open    { Hierarchy:ExpandNodeN $w $np 1 }
549         toggle  {
550             if {$data(:$np,showkids)} {
551                 Hierarchy:CollapseNodeAll $w $np
552             } else {
553                 Hierarchy:ExpandNodeN $w $np 1
554             }
555         }
556     }
557     if {[string compare {} $data(-command)]} {
558         uplevel \#0 $data(-command) [list $w $np $data(:$np,showkids)]
559     }
560     $data(basecmd) config -cursor $old
561     return
562 }
563
564 ;proc Hierarchy:Resize { w wid hgt } {
565     upvar \#0 $w data
566     set c $data(basecmd)
567     if {[string compare {} [set box [$c bbox image text]]]} {
568         set X [lindex $box 2]
569         if {$data(-autoscrollbar)} {
570             set Y [lindex $box 3]
571             if {$wid>$X} {
572                 set X $wid
573                 grid remove $data(xscrollbar)
574             } else {
575                 grid $data(xscrollbar)
576             }
577             if {$hgt>$Y} {
578                 set Y $hgt
579                 grid remove $data(yscrollbar)
580             } else {
581                 grid $data(yscrollbar)
582             }
583             $c config -scrollregion "0 0 $X $Y"
584         }
585         ## This makes full width highlight boxes
586         ## data(width) is the default width of boxes
587         if {$X>$data(width)} {
588             set data(width) $X
589             foreach b [$c find withtag box] {
590                 foreach {x y x1 y1} [$c coords $b] { $c coords $b 0 $y $X $y1 }
591             }
592         }
593     } elseif {$data(-autoscrollbar)} {
594         grid remove $data(xscrollbar) $data(yscrollbar)
595     }
596 }
597
598 ;proc Hierarchy:CollapseNodeAll { w np } {
599     if {[Hierarchy:CollapseNode $w $np]} {
600         upvar \#0 $w data
601         Hierarchy:Redraw $w $np
602         Hierarchy:DiscardChildren $w $np
603         Hierarchy:Resize $w [winfo width $data(canvas)] \
604                 [winfo height $data(canvas)]
605     }
606 }
607
608 ;proc Hierarchy:ExpandNodeN { w np n } {
609     upvar \#0 $w data
610     if {[Hierarchy:ExpandNodeN_aux $w $np $n] || \
611             ([string compare $data(-root) {}] && \
612             ![string compare $data(-root) $np])} {
613         Hierarchy:Redraw $w $np
614         Hierarchy:Resize $w [winfo width $data(canvas)] \
615                 [winfo height $data(canvas)]
616     }
617 }
618
619 ;proc Hierarchy:ExpandNodeN_aux { w np n } {
620     if {![Hierarchy:ExpandNode $w $np]} { return 0 }
621     if {$n==1} { return 1 }
622     incr n -1
623     upvar \#0 $w data
624     foreach k $data(:$np,kids) {
625         Hierarchy:ExpandNodeN_aux $w "$np [list $k]" $n
626     }
627     return 1
628 }
629
630 ########################################################################
631 ##
632 ## Private routines to collapse and expand a single node w/o redrawing
633 ## Most routines return 0/1 to indicate if any change has occurred
634 ##
635 ########################################################################
636
637 ;proc Hierarchy:ExpandNode { w np } {
638     upvar \#0 $w data
639
640     if {$data(:$np,showkids)} { return 0 }
641     set data(:$np,showkids) 1
642     if {![info exists data(:$np,kids)]} {
643         if {[string compare $data(-browsecmd) {}]} {
644             set data(:$np,kids) [uplevel \#0 $data(-browsecmd) [list $w $np]]
645         } else {
646             set data(:$np,kids) {}
647         }
648     }
649     if $data(hasnodelook) {
650         set data(:$np,look) [uplevel \#0 $data(-nodelook) [list $w $np 1]]
651     } else {
652         set data(:$np,look) {}
653     }
654     if {[string match {} $data(:$np,kids)]} {
655         foreach {txt font img fg} $data(:$np,look) {
656             lappend tags box:$np box $np
657             set c $data(basecmd)
658             if {[string compare $img {}]} {
659                 ## Catch just in case the image doesn't exist
660                 catch {
661                     $c itemconfigure img:$np -image $img
662                     lappend tags $img
663                 }
664             }
665             if {[string compare $txt {}]} {
666                 if {[string match {} $font]} { set font $data(-font) }
667                 if {[string match {} $fg]}   { set fg $data(-foreground) }
668                 $c itemconfigure txt:$np -fill $fg -text $txt -font $font
669                 if {[string compare $np $txt]} { lappend tags $txt }
670             }
671             $c itemconfigure box:$np -tags $tags
672             ## We only want to go through once
673             break
674         }
675         return 0
676     }
677     foreach k $data(:$np,kids) {
678         set knp "$np [list $k]"
679         set data(:$knp,showkids) 0
680         if $data(hasnodelook) {
681             set data(:$knp,look) [uplevel \#0 $data(-nodelook) [list $w $knp 0]]
682         } else {
683             set data(:$knp,look) {}
684         }
685     }
686     return 1
687 }
688
689 ;proc Hierarchy:CollapseNode { w np } {
690     upvar \#0 $w data
691     if {!$data(:$np,showkids)} { return 0 }
692     set data(:$np,showkids) 0
693     if {[string match {} $data(:$np,kids)]} { return 0 }
694     if {[string compare $data(-nodelook) {}]} {
695         set data(:$np,look) [uplevel \#0 $data(-nodelook) [list $w $np 0]]
696     } else {
697         set data(:$np,look) {}
698     }
699     foreach k $data(:$np,kids) { Hierarchy:CollapseNode $w "$np [list $k]" }
700     return 1
701 }
702
703 ;proc Hierarchy:DiscardChildren { w np } {
704     upvar \#0 $w data
705     if {[info exists data(:$np,kids)]} {
706         foreach k $data(:$np,kids) {
707             set knp "$np [list $k]"
708             $data(basecmd) delete img:$knp txt:$knp box:$knp
709             foreach i {showkids look stkusg stack iwidth offset} {
710                 catch {unset data(:$knp,$i)}
711             }
712             Hierarchy:DiscardChildren $w $knp
713         }
714         unset data(:$np,kids)
715     }
716 }
717
718 ## REDRAW mechanism
719 ## 2 parts:     recompute offsets of all children from changed node path
720 ##              then redraw children based on their offsets and look
721 ##
722 ;proc Hierarchy:Redraw { w cnp } {
723     upvar \#0 $w data
724
725     set c $data(basecmd)
726     # When a node changes, the positions of a whole lot of things
727     # change.  The size of the scroll region also changes.
728     $c delete decor
729
730     # Calculate the new offset locations of everything
731     Hierarchy:Recompute $w $data(-root) [lrange $cnp 1 end]
732
733     # Next recursively move all the bits around to their correct positions.
734     # We choose an initial point (4,4) to begin at.
735     Hierarchy:Redraw_aux $w $data(-root) 4 4
736
737     # Necessary to make sure find closest gets the right item
738     # ordering: image > text > box
739     after idle "catch { $c raise image text; $c lower box text }"
740 }
741
742 ## RECOMPUTE recurses through the tree working out the relative offsets
743 ## of children from their parents in terms of stack values.  
744 ##
745 ## "cnp" is either empty or a node name which indicates where the only
746 ## changes have occured in the hierarchy since the last call to Recompute.
747 ## This is used because when a node is toggled on/off deep in the
748 ## hierarchy then not all the positions of items need to be recomputed.
749 ## The only ones that do are everything below the changed node (of
750 ## course), and also everything which might depend on the stack usage of
751 ## that node (i.e. everything above it).  Specifically the usages of the
752 ## changed node's siblings do *not* need to be recomputed.
753 ##
754 ;proc Hierarchy:Recompute { w np cnp } {
755     upvar \#0 $w data
756     # If the cnp now has only one element then
757     # it must be one of the children of the current node.
758     # We do not need to Recompute the usages of its siblings if it is.
759     set cnode_is_child [expr [llength $cnp]==1]
760     if {$cnode_is_child} {
761         set cnode [lindex $cnp 0]
762     } else {
763         set xcnp [lrange $cnp 1 end]
764     }
765     
766     # Run through the children, recursively calculating their usage of
767     # stack real-estate, and allocating an intial placement for each child
768     #
769     # Values do not need to be recomputed for siblings of the changed
770     # node and their descendants.  For the cnode itself, in the
771     # recursive call we set the value of cnode to {} to prevent
772     # any further cnode checks.
773
774     set children_stack 0
775     if {$data(:$np,showkids)} { 
776         foreach k $data(:$np,kids) {
777             set knp "$np [list $k]"
778             set data(:$knp,offset) $children_stack
779             if {$cnode_is_child && [string match $cnode $k]} {
780                 set data(:$knp,stkusg) [Hierarchy:Recompute $w $knp {}]
781             } elseif {!$cnode_is_child} {
782                 set data(:$knp,stkusg) [Hierarchy:Recompute $w $knp $xcnp]
783             }
784             incr children_stack $data(:$knp,stkusg)
785             incr children_stack $data(-padstack)
786         }
787     }
788
789     ## Make the image/text if they don't exist.
790     ## Positioning occurs in Hierarchy:Redraw_aux.
791     ## And calculate the stack usage of our little piece of the world.
792     set img_height 0; set img_width 0; set txt_width 0; set txt_height 0
793
794     foreach {txt font img fg} $data(:$np,look) {
795         lappend tags box:$np box $np
796         set c $data(basecmd)
797         if {[string compare $img {}]} {
798             if {[string match {} [$c find withtag img:$np]]} {
799                 $c create image 0 0 -anchor nw -tags [list img:$np image]
800             }
801             ## Catch just in case the image doesn't exist
802             catch {
803                 $c itemconfigure img:$np -image $img
804                 lappend tags $img
805                 foreach {x y img_width img_height} [$c bbox img:$np] {
806                     incr img_width -$x; incr img_height -$y
807                 }
808             }
809         }
810         if {[string compare $txt {}]} {
811             if {[string match {} [$c find withtag txt:$np]]} {
812                 $c create text 0 0 -anchor nw -tags [list txt:$np text]
813             }
814             if {[string match {} $font]} { set font $data(-font) }
815             if {[string match {} $fg]}   { set fg $data(-foreground) }
816             $c itemconfigure txt:$np -fill $fg -text $txt -font $font
817             if {[string compare $np $txt]} { lappend tags $txt }
818             foreach {x y txt_width txt_height} [$c bbox txt:$np] {
819                 incr txt_width -$x; incr txt_height -$y
820             }
821         }
822         if {[string match {} [$c find withtag box:$np]]} {
823             $c create rect 0 0 1 1 -tags [list box:$np box] -outline {}
824         }
825         $c itemconfigure box:$np -tags $tags
826         ## We only want to go through this once
827         break
828     }
829
830     if {$txt_height>$img_height} {
831         set stack $txt_height
832     } else {
833         set stack $img_height
834     }
835
836     # Now reposition the children downward by "stack"
837     set overall_stack [expr $children_stack+$stack]
838
839     if {$data(:$np,showkids)} { 
840         set off [expr $stack+$data(-padstack)]
841         foreach k $data(:$np,kids) {
842             set knp "$np [list $k]"
843             incr data(:$knp,offset) $off
844         }
845     }
846     # remember some facts for locating the image and drawing decor
847     array set data [list :$np,stack $stack :$np,iwidth $img_width]
848
849     return $overall_stack
850 }
851
852 ;proc Hierarchy:Redraw_aux { w np deppos stkpos} {
853     upvar \#0 $w data
854
855     set c $data(basecmd)
856     $c coords img:$np $deppos $stkpos
857     $c coords txt:$np [expr {$deppos+$data(:$np,iwidth)+$data(-ipad)}] $stkpos
858     $c coords box:$np 0 [expr $stkpos-$data(halfpstk)] \
859             $data(width) [expr $stkpos+$data(:$np,stack)+$data(halfpstk)]
860
861     if {!$data(:$np,showkids) || [string match {} $data(:$np,kids)]} return
862
863     set minkid_stkpos 100000
864     set maxkid_stkpos 0
865     set bar_deppos [expr $deppos+$data(-paddepth)/2]
866     set kid_deppos [expr $deppos+$data(-paddepth)]
867
868     foreach k $data(:$np,kids) {
869         set knp "$np [list $k]"
870         set kid_stkpos [expr $stkpos+$data(:$knp,offset)]
871         Hierarchy:Redraw_aux $w $knp $kid_deppos $kid_stkpos
872         
873         if {$data(-decoration)} {
874             if {$kid_stkpos<$minkid_stkpos} {set minkid_stkpos $kid_stkpos}
875             set kid_stkpos [expr $kid_stkpos+$data(:$knp,stack)/2]
876             if {$kid_stkpos>$maxkid_stkpos} {set maxkid_stkpos $kid_stkpos}
877             
878             $c create line $bar_deppos $kid_stkpos $kid_deppos $kid_stkpos \
879                     -width 1 -tags decor
880         }
881     }
882     if {$data(-decoration)} {
883         $c create line $bar_deppos $minkid_stkpos $bar_deppos $maxkid_stkpos \
884                 -width 1 -tags decor
885     }
886 }
887
888
889 ##
890 ## DEFAULT BINDINGS FOR HIERARCHY
891 ##
892 ## Since we give no border to the frame, all Hierarchy bindings
893 ## will always register on the canvas widget
894 ##
895 bind Hierarchy <Double-Button-1> {
896     set w [winfo parent %W]
897     if {[string match normal [$w cget -state]]} {
898         $w toggle @%x,%y
899     }
900 }
901 bind Hierarchy <ButtonPress-1> {
902     if {[winfo exists %W]} { Hierarchy:BeginSelect [winfo parent %W] @%x,%y }
903 }
904 bind Hierarchy <B1-Motion> {
905     set tkPriv(x) %x
906     set tkPriv(y) %y
907     Hierarchy:Motion [winfo parent %W] @%x,%y
908 }
909 bind Hierarchy <ButtonRelease-1> { tkCancelRepeat }
910 bind Hierarchy <Shift-1>   { Hierarchy:BeginExtend [winfo parent %W] @%x,%y }
911 bind Hierarchy <Control-1> { Hierarchy:BeginToggle [winfo parent %W] @%x,%y }
912 bind Hierarchy <B1-Leave> {
913     set tkPriv(x) %x
914     set tkPriv(y) %y
915     Hierarchy:AutoScan [winfo parent %W]
916 }
917 bind Hierarchy <B1-Enter>       { tkCancelRepeat }
918
919 ## Should reserve L/R U/D for traversing nodes
920 bind Hierarchy <Up>             { %W yview scroll -1 units }
921 bind Hierarchy <Down>           { %W yview scroll  1 units }
922 bind Hierarchy <Left>           { %W xview scroll -1 units }
923 bind Hierarchy <Right>          { %W xview scroll  1 units }
924
925 bind Hierarchy <Control-Up>     { %W yview scroll -1 pages }
926 bind Hierarchy <Control-Down>   { %W yview scroll  1 pages }
927 bind Hierarchy <Control-Left>   { %W xview scroll -1 pages }
928 bind Hierarchy <Control-Right>  { %W xview scroll  1 pages }
929 bind Hierarchy <Prior>          { %W yview scroll -1 pages }
930 bind Hierarchy <Next>           { %W yview scroll  1 pages }
931 bind Hierarchy <Control-Prior>  { %W xview scroll -1 pages }
932 bind Hierarchy <Control-Next>   { %W xview scroll  1 pages }
933 bind Hierarchy <Home>           { %W xview moveto 0 }
934 bind Hierarchy <End>            { %W xview moveto 1 }
935 bind Hierarchy <Control-slash>  { Hierarchy:SelectAll [winfo parent %W] }
936 bind Hierarchy <Control-backslash> { [winfo parent %W] selection clear }
937
938 bind Hierarchy <2> {
939     set tkPriv(x) %x
940     set tkPriv(y) %y
941     %W scan mark %x %y
942 }
943 bind Hierarchy <B2-Motion> {
944     %W scan dragto $tkPriv(x) %y
945 }
946
947 # Hierarchy:BeginSelect --
948 #
949 # This procedure is typically invoked on button-1 presses.  It begins
950 # the process of making a selection in the hierarchy.  Its exact behavior
951 # depends on the selection mode currently in effect for the hierarchy;
952 # see the Motif documentation for details.
953 #
954 # Arguments:
955 # w -           The hierarchy widget.
956 # el -          The element for the selection operation (typically the
957 #               one under the pointer).  Must be in numerical form.
958
959 ;proc Hierarchy:BeginSelect {w el} {
960     global tkPriv
961     if {[catch {Hierarchy_index $w $el} el]} return
962     $w selection clear
963     $w selection set $el
964     set tkPriv(hierarchyPrev) $el
965 }
966
967 # Hierarchy:Motion --
968 #
969 # This procedure is called to process mouse motion events while
970 # button 1 is down.  It may move or extend the selection, depending
971 # on the hierarchy's selection mode.
972 #
973 # Arguments:
974 # w -           The hierarchy widget.
975 # el -          The element under the pointer (must be a number).
976
977 ;proc Hierarchy:Motion {w el} {
978     global tkPriv
979     if {[catch {Hierarchy_index $w $el} el] || \
980             [string match $el $tkPriv(hierarchyPrev)]} return
981     switch [Hierarchy_cget $w -selectmode] {
982         browse {
983             Hierarchy_selection $w clear 0 end
984             if {![catch {Hierarchy_selection $w set $el}]} {
985                 set tkPriv(hierarchyPrev) $el
986             }
987         }
988         multiple {
989             ## This happens when a double-1 occurs and all the index boxes
990             ## have changed
991             if {[catch {Hierarchy_selection $w includes \
992                     $tkPriv(hierarchyPrev)} inc]} {
993                 set tkPriv(hierarchyPrev) [Hierarchy_index $w $el]
994                 return
995             }
996             if {$inc} {
997                 Hierarchy_selection $w set $el
998             } else {
999                 Hierarchy_selection $w clear $el
1000             }
1001             set tkPriv(hierarchyPrev) $el
1002         }
1003     }
1004 }
1005
1006 # Hierarchy:BeginExtend --
1007 #
1008 # This procedure is typically invoked on shift-button-1 presses.  It
1009 # begins the process of extending a selection in the hierarchy.  Its
1010 # exact behavior depends on the selection mode currently in effect
1011 # for the hierarchy;
1012 #
1013 # Arguments:
1014 # w -           The hierarchy widget.
1015 # el -          The element for the selection operation (typically the
1016 #               one under the pointer).  Must be in numerical form.
1017
1018 ;proc Hierarchy:BeginExtend {w el} {
1019     if {[catch {Hierarchy_index $w $el} el]} return
1020     if {[string match multiple [$w cget -selectmode]]} {
1021         Hierarchy:Motion $w $el
1022     }
1023 }
1024
1025 # Hierarchy:BeginToggle --
1026 #
1027 # This procedure is typically invoked on control-button-1 presses.  It
1028 # begins the process of toggling a selection in the hierarchy.  Its
1029 # exact behavior depends on the selection mode currently in effect
1030 # for the hierarchy;  see the Motif documentation for details.
1031 #
1032 # Arguments:
1033 # w -           The hierarchy widget.
1034 # el -          The element for the selection operation (typically the
1035 #               one under the pointer).  Must be in numerical form.
1036
1037 ;proc Hierarchy:BeginToggle {w el} {
1038     global tkPriv
1039     if {[catch {Hierarchy_index $w $el} el]} return
1040     if {[string match multiple [$w cget -selectmode]]} {
1041         $w selection anchor $el
1042         if {[$w selection includes $el]} {
1043             $w selection clear $el
1044         } else {
1045             $w selection set $el
1046         }
1047         set tkPriv(hierarchyPrev) $el
1048     }
1049 }
1050
1051 # Hierarchy:AutoScan --
1052 # This procedure is invoked when the mouse leaves an entry window
1053 # with button 1 down.  It scrolls the window up, down, left, or
1054 # right, depending on where the mouse left the window, and reschedules
1055 # itself as an "after" command so that the window continues to scroll until
1056 # the mouse moves back into the window or the mouse button is released.
1057 #
1058 # Arguments:
1059 # w -           The hierarchy widget.
1060
1061 ;proc Hierarchy:AutoScan {w} {
1062     global tkPriv
1063     if {![winfo exists $w]} return
1064     set x $tkPriv(x)
1065     set y $tkPriv(y)
1066     if {$y>=[winfo height $w]} {
1067         $w yview scroll 1 units
1068     } elseif {$y<0} {
1069         $w yview scroll -1 units
1070     } elseif {$x>=[winfo width $w]} {
1071         $w xview scroll 2 units
1072     } elseif {$x<0} {
1073         $w xview scroll -2 units
1074     } else {
1075         return
1076     }
1077     #Hierarchy:Motion $w [$w index @$x,$y]
1078     set tkPriv(afterId) [after 50 Hierarchy:AutoScan $w]
1079 }
1080
1081 # Hierarchy:SelectAll
1082 #
1083 # This procedure is invoked to handle the "select all" operation.
1084 # For single and browse mode, it just selects the root element.
1085 # Otherwise it selects everything in the widget.
1086 #
1087 # Arguments:
1088 # w -           The hierarchy widget.
1089
1090 ;proc Hierarchy:SelectAll w {
1091     if {[regexp (browse|single) [$w cget -selectmode]]} {
1092         $w selection clear
1093         $w selection set root
1094     } else {
1095         $w selection set all
1096     }
1097 }
1098
1099 #------------------------------------------------------------
1100 # Default nodelook methods
1101 #------------------------------------------------------------
1102
1103 ;proc Hierarchy:FileLook { w np isopen } {
1104     upvar \#0 $w data
1105     set path [eval file join $np]
1106     set file [lindex $np end]
1107     set bmp  {}
1108     if {[file readable $path]} {
1109         if {[file isdirectory $path]} {
1110             if {$isopen} {
1111                 ## We know that kids will always be set by the time
1112                 ## the isopen is set to 1
1113                 if {[string compare $data(:$np,kids) {}]} {
1114                     set bmp bmp:dir_minus
1115                 } else {
1116                     set bmp bmp:dir
1117                 }
1118             } else {
1119                 set bmp bmp:dir_plus
1120             }
1121             if 0 {
1122                 ## NOTE: accurate, but very expensive
1123                 if {[string compare [Hierarchy:FileList $w $np] {}]} {
1124                     if {$isopen} {set bmp bmp:dir_minus} {set bmp bmp:dir_plus}
1125                 } else {
1126                     set bmp bmp:dir
1127                 }
1128             }
1129         }
1130         set fg \#000000
1131     } elseif {[string compare $data(-showparent) {}] && \
1132             [string match $data(-showparent) $file]} {
1133         set fg \#0000FF
1134         set bmp bmp:up
1135     } else {
1136         set fg \#a9a9a9
1137         if {[file isdirectory $path]} {set bmp bmp:dir}
1138     }
1139     return [list $file $data(-font) $bmp $fg] 
1140 }
1141
1142 ## Hierarchy:FileList
1143 # ARGS: w       hierarchy widget
1144 #       np      node path       
1145 # Returns:      directory listing
1146 ##
1147 ;proc Hierarchy:FileList { w np } {
1148     set pwd [pwd]
1149     if {[catch "cd \[file join $np\]"]} {
1150         set list {}
1151     } else {
1152         global tcl_platform
1153         upvar \#0 $w data
1154         set str *
1155         if {!$data(-showfiles)} { append str / }
1156         if {$data(-showall) && [string match unix $tcl_platform(platform)]} {
1157             ## NOTE: Use of non-core lremove
1158             if {[catch {lsort [concat [glob -nocomplain $str] \
1159                     [lremove [glob -nocomplain .$str] {. ..}]]} list]} {
1160                 return {}
1161             }
1162         } else {
1163             ## The extra catch is necessary for unusual error conditions
1164             if {[catch {lsort [glob -nocomplain $str]} list]} {
1165                 return {}
1166             }
1167         }
1168         set root $data(-root)
1169         if {[string compare {} $data(-showparent)] && \
1170                 [string match $root $np]} {
1171             if {![regexp {^(.:)?/+$} $root] && \
1172                     [string compare [file dir $root] $root]} {
1173                 set list [linsert $list 0 $data(-showparent)]
1174             }
1175         }
1176     }
1177     cd $pwd
1178     return $list
1179 }
1180
1181 ;proc Hierarchy:FileActivate { w np isopen } {
1182     upvar \#0 $w data
1183     set path [eval file join $np]
1184     if {[file isdirectory $path]} return
1185     if {[string compare $data(-showparent) {}] && \
1186             [string match $data(-showparent) [lindex $np end]]} {
1187         $w config -root [file dir $data(-root)]
1188     }
1189 }
1190
1191 ;proc Hierarchy:WidgetLook { W np isopen } {
1192     upvar \#0 $W data
1193     if {$data(-showall)} {
1194         set w [lindex $np end]
1195     } else {
1196         set w [join $np {}]
1197         regsub {\.\.} $w {.} w
1198     }
1199     if {[string compare [winfo children $w] {}]} {set fg blue} {set fg black}
1200     return [list "\[[winfo class $w]\] [lindex $np end]" {} {} $fg]
1201 }
1202
1203 ;proc Hierarchy:WidgetList { W np } {
1204     upvar \#0 $W data
1205     if {$data(-showall)} {
1206         set w [lindex $np end]
1207     } else {
1208         set w [join $np {}]
1209         regsub {\.\.} $w {.} w
1210     }
1211     set kids {}
1212     foreach i [lsort [winfo children $w]] {
1213         if {$data(-showall)} {
1214             lappend kids $i
1215         } else {
1216             lappend kids [file extension $i]
1217         }
1218     }
1219     return $kids
1220 }
1221
1222 ;proc Hierarchy:WidgetActivate { w np isopen } {}
1223
1224
1225 ## BITMAPS
1226 ##
1227 image create bitmap bmp:dir -data {#define folder_width 16
1228 #define folder_height 12
1229 static char folder_bits[] = {
1230   0x00, 0x1f, 0x80, 0x20, 0x40, 0x20, 0xfc, 0x7f, 0x02, 0x40, 0x02, 0x40,
1231   0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0xfe, 0x7f};}
1232 image create bitmap bmp:dir_plus -data {#define folder_plus_width 16
1233   #define folder_plus_height 12
1234 static char folder_plus_bits[] = {
1235   0x00, 0x1f, 0x80, 0x20, 0x40, 0x20, 0xfc, 0x7f, 0x02, 0x40, 0x82, 0x40,
1236   0x82, 0x40, 0xe2, 0x43, 0x82, 0x40, 0x82, 0x40, 0x02, 0x40, 0xfe, 0x7f};}
1237 image create bitmap bmp:dir_minus -data {#define folder_minus_width 16
1238 #define folder_minus_height 12
1239 static char folder_minus_bits[] = {
1240   0x00, 0x1f, 0x80, 0x20, 0x40, 0x20, 0xfc, 0x7f, 0x02, 0x40, 0x02, 0x40,
1241   0x02, 0x40, 0xe2, 0x43, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0xfe, 0x7f};}
1242 image create bitmap bmp:up -data {#define up.xbm_width 16
1243 #define up.xbm_height 12
1244 static unsigned char up.xbm_bits[] = {
1245   0x00, 0x00, 0x10, 0x00, 0x38, 0x00, 0x7c, 0x00, 0xfe, 0x00, 0x38, 0x00,
1246   0x38, 0x00, 0x38, 0x00, 0xf8, 0x7f, 0xf0, 0x7f, 0xe0, 0x7f, 0x00, 0x00};}
1247 image create bitmap bmp:text -data {#define text_width 15
1248 #define text_height 14
1249 static char text_bits[] = {
1250   0xff,0x07,0x01,0x0c,0x01,0x04,0x01,0x24,0xf9,0x7d,0x01,0x78,0x01,0x40,0xf1,
1251   0x41,0x01,0x40,0x01,0x40,0xf1,0x41,0x01,0x40,0x01,0x40,0xff,0x7f};}
1252
1253 return