1# 2# help.tcl -- 3# 4# Tcl help command. (see TclX manual) 5# 6#------------------------------------------------------------------------------ 7# Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. 8# 9# Permission to use, copy, modify, and distribute this software and its 10# documentation for any purpose and without fee is hereby granted, provided 11# that the above copyright notice appear in all copies. Karl Lehenbauer and 12# Mark Diekhans make no representations about the suitability of this 13# software for any purpose. It is provided "as is" without express or 14# implied warranty. 15#------------------------------------------------------------------------------ 16# The help facility is based on a hierarchical tree of subjects (directories) 17# and help pages (files). There is a virtual root to this tree. The root 18# being the merger of all "help" directories found along the $auto_path 19# variable. 20#------------------------------------------------------------------------------ 21# $Id: help.tcl,v 1.2 2004/11/23 05:54:15 hobbs Exp $ 22#------------------------------------------------------------------------------ 23# 24 25#@package: TclX-help help helpcd helppwd apropos 26 27namespace eval ::tclx { 28 namespace export help helpcd helppwd apropos 29} 30 31namespace eval ::tclx::help { 32 variable curSubject "/" 33} 34 35#------------------------------------------------------------------------------ 36# Help command. 37 38proc ::tclx::help {{what {}}} { 39 variable ::tclx::help::lineCnt 0 40 41 # Special case "help help", so we can get it at any level. 42 43 if {($what == "help") || ($what == "?")} { 44 tclx::help::HelpOnHelp 45 return 46 } 47 48 set pathList [tclx::help::ConvertPath $what] 49 if {[file isfile [lindex $pathList 0]]} { 50 tclx::help::DisplayPage [lindex $pathList 0] 51 return 52 } 53 54 tclx::help::ListSubject $what $pathList subjects pages 55 set relativeDir [tclx::help::RelativePath [lindex $pathList 0]] 56 57 if {[llength $subjects] != 0} { 58 tclx::help::Display "\nSubjects available in $relativeDir:" 59 tclx::help::DisplayColumns $subjects 60 } 61 if {[llength $pages] != 0} { 62 tclx::help::Display "\nHelp pages available in $relativeDir:" 63 tclx::help::DisplayColumns $pages 64 } 65} 66 67 68#------------------------------------------------------------------------------ 69# helpcd command. The name of the new current directory is assembled from the 70# current directory and the argument. 71 72proc ::tclx::helpcd {{dir /}} { 73 variable ::tclx::help::curSubject 74 75 set pathName [lindex [tclx::help::ConvertPath $dir] 0] 76 77 if {![file isdirectory $pathName]} { 78 error "\"$dir\" is not a subject" [list TCLXHELP NOTSUBJECT $dir] 79 } 80 81 set ::tclx::help::curSubject [tclx::help::RelativePath $pathName] 82 return 83} 84 85#------------------------------------------------------------------------------ 86# Helpcd main. 87 88proc ::tclx::helppwd {} { 89 variable ::tclx::help::curSubject 90 echo "Current help subject: $::tclx::help::curSubject" 91} 92 93#------------------------------------------------------------------------------ 94# apropos command. This search the 95 96proc ::tclx::apropos {regexp} { 97 variable ::tclx::help::lineCnt 0 98 variable ::tclx::help::curSubject 99 100 set ch [scancontext create] 101 scanmatch -nocase $ch $regexp { 102 set path [lindex $matchInfo(line) 0] 103 set desc [lrange $matchInfo(line) 1 end] 104 if {![tclx::help::Display [format "%s - %s" $path $desc]]} { 105 set stop 1 106 return 107 } 108 } 109 set stop 0 110 foreach dir [tclx::help::RootDirs] { 111 foreach brief [glob -nocomplain $dir/*.brf] { 112 set briefFH [open $brief] 113 try_eval { 114 scanfile $ch $briefFH 115 } {} { 116 close $briefFH 117 } 118 if {$stop} break 119 } 120 if {$stop} break 121 } 122 scancontext delete $ch 123} 124 125## 126## Private Helper Routines 127## 128 129#---------------------------------------------------------------------- 130# Return a list of help root directories. 131 132proc ::tclx::help::RootDirs {} { 133 global auto_path 134 set roots {} 135 foreach dir $auto_path { 136 if {[file isdirectory $dir/help]} { 137 lappend roots $dir/help 138 } 139 } 140 return $roots 141} 142 143#-------------------------------------------------------------------------- 144# Take a path name which might have "." and ".." elements and flatten them 145# out. Also removes trailing and adjacent "/", unless its the only 146# character. 147 148proc ::tclx::help::FlattenPath pathName { 149 set newPath {} 150 foreach element [split $pathName /] { 151 if {"$element" == "." || [lempty $element]} continue 152 153 if {"$element" == ".."} { 154 if {[llength [join $newPath /]] == 0} { 155 error "Help: name goes above subject directory root" {} \ 156 [list TCLXHELP NAMEABOVEROOT $pathName] 157 } 158 lvarpop newPath [expr [llength $newPath]-1] 159 continue 160 } 161 lappend newPath $element 162 } 163 set newPath [join $newPath /] 164 165 # Take care of the case where we started with something line "/" or "/." 166 167 if {("$newPath" == "") && [string match "/*" $pathName]} { 168 set newPath "/" 169 } 170 171 return $newPath 172} 173 174#-------------------------------------------------------------------------- 175# Given a pathName relative to the virtual help root, convert it to a list 176# of real file paths. A list is returned because the path could be "/", 177# returning a list of all roots. The list is returned in the same order of 178# the auto_path variable. If path does not start with a "/", it is take as 179# relative to the current help subject. Note: The root directory part of 180# the name is not flattened. This lets other commands pick out the part 181# relative to the one of the root directories. 182 183proc ::tclx::help::ConvertPath pathName { 184 variable curSubject 185 186 if {![string match "/*" $pathName]} { 187 if {[cequal $curSubject "/"]} { 188 set pathName "/$pathName" 189 } else { 190 set pathName "$curSubject/$pathName" 191 } 192 } 193 set pathName [FlattenPath $pathName] 194 195 # If the virtual root is specified, return a list of directories. 196 197 if {$pathName == "/"} { 198 return [RootDirs] 199 } 200 201 # Not the virtual root find the first match. 202 203 foreach dir [RootDirs] { 204 if {[file readable $dir/$pathName]} { 205 return [list $dir/$pathName] 206 } 207 } 208 209 # Not found, try to find a file matching only the file tail, 210 # for example if --> <helpDir>/tcl/control/if. 211 212 set fileTail [file tail $pathName] 213 foreach dir [RootDirs] { 214 set fileName [exec find $dir -name $fileTail | head -1] 215 if {$fileName != {}} { 216 return [list $fileName] 217 } 218 } 219 220 error "\"$pathName\" does not exist" {} \ 221 [list TCLXHELP NOEXIST $pathName] 222} 223 224#-------------------------------------------------------------------------- 225# Return the virtual root relative name of the file given its absolute 226# path. The root part of the path should not have been flattened, as we 227# would not be able to match it. 228 229proc ::tclx::help::RelativePath pathName { 230 foreach dir [RootDirs] { 231 if {[csubstr $pathName 0 [clength $dir]] == $dir} { 232 set name [csubstr $pathName [clength $dir] end] 233 if {$name == ""} {set name /} 234 return $name 235 } 236 } 237 if {![info exists found]} { 238 error "problem translating \"$pathName\"" {} [list TCLXHELP INTERROR] 239 } 240} 241 242#-------------------------------------------------------------------------- 243# Given a list of path names to subjects generated by ConvertPath, return 244# the contents of the subjects. Two lists are returned, subjects under 245# that subject and a list of pages under the subject. Both lists are 246# returned sorted. This merges all the roots into a virtual root. 247# pathName is the string that was passed to ConvertPath and is used for 248# error reporting. *.brk files are not returned. 249 250proc ::tclx::help::ListSubject {pathName pathList subjectsVar pagesVar} { 251 upvar $subjectsVar subjects $pagesVar pages 252 253 set subjects {} 254 set pages {} 255 set foundDir 0 256 foreach dir $pathList { 257 if {![file isdirectory $dir] || [cequal [file tail $dir] CVS]} continue 258 set foundDir 1 259 foreach file [glob -nocomplain $dir/*] { 260 if {[lsearch {.brf .orig .diff .rej} [file extension $file]] \ 261 >= 0} continue 262 if [file isdirectory $file] { 263 lappend subjects [file tail $file]/ 264 } else { 265 lappend pages [file tail $file] 266 } 267 } 268 } 269 if {!$foundDir} { 270 if {[cequal $pathName /]} { 271 global auto_path 272 error "no \"help\" directories found on auto_path ($auto_path)" {} \ 273 [list TCLXHELP NOHELPDIRS] 274 } else { 275 error "\"$pathName\" is not a subject" {} \ 276 [list TCLXHELP NOTSUBJECT $pathName] 277 } 278 } 279 set subjects [lsort $subjects] 280 set pages [lsort $pages] 281 return {} 282} 283 284#-------------------------------------------------------------------------- 285# Display a line of output, pausing waiting for input before displaying if 286# the screen size has been reached. Return 1 if output is to continue, 287# return 0 if no more should be outputed, indicated by input other than 288# return. 289# 290 291proc ::tclx::help::Display line { 292 variable lineCnt 293 if {$lineCnt >= 23} { 294 set lineCnt 0 295 puts -nonewline stdout ":" 296 flush stdout 297 gets stdin response 298 if {![lempty $response]} { 299 return 0} 300 } 301 puts stdout $line 302 incr lineCnt 303} 304 305#-------------------------------------------------------------------------- 306# Display a help page (file). 307 308proc ::tclx::help::DisplayPage filePath { 309 310 set inFH [open $filePath r] 311 try_eval { 312 while {[gets $inFH fileBuf] >= 0} { 313 if {![Display $fileBuf]} { 314 break 315 } 316 } 317 } {} { 318 close $inFH 319 } 320} 321 322#-------------------------------------------------------------------------- 323# Display a list of file names in a column format. This use columns of 14 324# characters 3 blanks. 325 326proc ::tclx::help::DisplayColumns {nameList} { 327 set count 0 328 set outLine "" 329 foreach name $nameList { 330 if {$count == 0} { 331 append outLine " " 332 } 333 append outLine $name 334 if {[incr count] < 4} { 335 set padLen [expr 17-[clength $name]] 336 if {$padLen < 3} { 337 set padLen 3} 338 append outLine [replicate " " $padLen] 339 } else { 340 if {![Display $outLine]} { 341 return} 342 set outLine "" 343 set count 0 344 } 345 } 346 if {$count != 0} { 347 Display [string trimright $outLine]} 348 return 349} 350 351 352#-------------------------------------------------------------------------- 353# Display help on help, the first occurance of a help page called "help" in 354# the help root. 355 356proc ::tclx::help::HelpOnHelp {} { 357 set helpPage [lindex [ConvertPath /help] 0] 358 if {[lempty $helpPage]} { 359 error "No help page on help found" {} \ 360 [list TCLXHELP NOHELPPAGE] 361 } 362 DisplayPage $helpPage 363} 364 365