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 " " 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 - " " 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}