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