1#!/bin/sh
2#\
3exec tclsh $0 -test "$@"
4########################################################################
5#
6# An attempt for a navigation bar on the left. Layout done with a
7# table.
8#
9# (C) 2002 Harald Kirsch
10# $Revision: 1.3 $, $Date: 2002/08/07 17:33:08 $
11########################################################################
12
13namespace eval ::htmlgen::sidenav {
14
15namespace export sidenav
16
17## default values for configurable attributes of sidenav
18set sidenavDefaultAttrs {
19    nav.valign top
20    txt.valign top
21    nav.width 100
22    main.border 0
23    main.cellspacing 0
24    main.cellpadding 2
25    main.width 100%
26    curColor red
27    navByUrl 0
28}
29
30
31########################################################################
32## Create an indented table row with some colored content
33## Indentation is faked with a full table having some empty columns in
34## front.
35##
36proc onerow {text level} {
37  for {set i 0} {$i<$level} {incr i} {
38    put "&nbsp;&nbsp;&nbsp;"
39    set text [small $text]
40  }
41  put $text [br] \n
42  return
43}
44
45
46########################################################################
47## Find unique node name $current within $tree and return the full
48## path.
49proc digTree {current tree} {
50  foreach {node text subtree} $tree {
51    if {"$node"=="$current"} {return $current}
52    if {[llength $subtree]<3} continue
53    set rest [digTree $current $subtree]
54    if {""=="$rest"} continue
55    return [concat [list $node] $rest]
56  }
57  return ""
58}
59
60
61########################################################################
62## Render a navigation tree along a path given by $current leading
63## into the tree. Every level of the tree is created as a block. The
64## blocks are separated by horizontal rules. On every level, the
65## selected element is printed in the color given by attribute
66## curColor.
67##
68## We descend into subtrees only if $current really selects one of
69## them. If $current contains nonsense, only the top level of the tree
70## is rendered with nothing selected. The verified part of $current is
71## returned in the end.
72proc renderTree {ID url current tree} {
73  upvar A A
74  set level 0
75  set path {}
76  set newpath {}
77
78  if {$A(navByUrl)} {
79    set current [digTree $current $tree]
80  }
81  ## A tree of length 1 indicates an empty tree. Nonempty trees have
82  ## a multiple of 2 elements.
83  while {[llength $tree]>1} {
84    if {[llength $tree]%3!=0} {
85      set l [split $tree \n]
86      append msg "navigation tree must have length of 3*n:\n" \
87	  \"[join [lrange $l 0 3] \n]
88      if {[llength $l]>4} { append msg "\n  ...\"" }
89      return -code error $msg
90    }
91    set head [lindex $current 0]
92    if {$level>0} { put [hr] }
93
94    set tmp $tree
95    set tree .
96    foreach {node text subtree} $tmp {
97      if {$A(navByUrl)} {
98	set href $url/$node
99      } else {
100	set href $url?[::htmlgen::cgiset $ID [concat $path [list $node]]]
101      }
102      if {"$node"!="$head"} {
103	onerow [a href=$href $text] $level
104	continue
105      }
106      ## we hit a selected node, so we can extend the verified path
107      ## and prepare to descent into the subtree
108      set newpath [concat $path [list $node]]
109      set tree $subtree
110      if {[llength $current]==1} {
111	## exactly the selected node, so no link
112	onerow [font color=$A(curColor) $text] $level
113      } else {
114	onerow [a href=$href [font color=$A(curColor) $text]] $level
115      }
116    }
117    set path $newpath
118    set current [lrange $current 1 end]
119    incr level
120  }
121  return $path
122}
123
124
125proc attrget {aryname prefix} {
126  upvar $aryname A
127  set res {}
128  set l [string length ${prefix}.]
129  foreach x [array names A ${prefix}.*] {
130    set suf [string range $x $l end]
131    if {-1!=[string first . $suf]} continue
132    lappend res $suf=$A($x)
133  }
134  return $res
135}
136
137
138proc sidenav {pathvar url tree args} {
139  upvar $pathvar path
140  variable sidenavDefaultAttrs
141  array set A $sidenavDefaultAttrs
142
143  foreach {opentag control body closetag} \
144      [::xmlgen::makeTagAndBody {} $args A] break
145
146  eval table [attrget A main] ! {{
147    tr ! {
148      eval td [attrget A nav] ! {{
149	set path [renderTree $pathvar $url $path $tree]
150      }}
151      eval td [attrget A txt] ! {{
152	uplevel 1 "::xmlgen::runbody {} {$control} {$body} {}"
153      }}
154    }
155  }}
156}
157########################################################################
158
159set testScript {
160## BEGIN TEST SCRIPT
161    set auto_path [concat . /home/kir/work /usr/local/lib $auto_path]
162    foreach {i} {tcllib htmlgen ncgi} { package require $i }
163    namespace import -force htmlgen::*
164    namespace import -force ::htmlgen::sidenav::*
165
166    # Start of HTML Content
167    ::ncgi::parse
168
169    set navTree {
170      home Home .
171      tcl Tcl {
172        kit TclKit .
173        w83 Wish83 {
174          story Story .
175          doc Documentation .
176        }
177        fw FreeWrap .
178      }
179      perl Perl {
180        bad {Perl No Fun} .
181        doc {NO DOCS} .
182      }
183    }
184
185    html ! {
186      body ! {
187        set url [ncgi::urlStub]
188        set path [ncgi::value path {tcl}]
189        sidenav path $url $navTree nav.bgcolor=\#dddd55 txt.bgcolor=\#dddd00 ! {
190          h2 - Some Information about [join $path /]
191          p + {
192    	The selected path is
193          }
194          blockquote - [code . path="$path"].
195          p + {
196    	Depending on that,
197    	we could have different content introduced here in several
198    	ways, e.g.
199          }
200          ul ! {
201    	li - use a [code switch on \$path]
202    	li - access a content array like [code \$Content(\$path)]
203    	li - source a file depending on \$path
204          }
205          table ! tr ! td height=1000 - "&nbsp;"
206        }
207      }
208    }
209    # Finish with regular puts to end with newline
210    puts {}
211
212### END TEST SCRIPT
213}
214
215### END NAMESPACE
216}
217
218# Execute test script if -test option specified
219if { [string match "-test" [lindex $argv 0]] } {
220    ::xmlgen::buffer html $::htmlgen::sidenav::testScript
221    set fh [open test.html w]; puts $fh $html; close $fh
222}