]> git.zerfleddert.de Git - micropolis/blame_incremental - src/tclx/tclsrc/help.tcl
src/tk/tkevent.c: Micropolis build fixes for recent macOS
[micropolis] / src / tclx / tclsrc / help.tcl
... / ...
CommitLineData
1#
2# help.tcl --
3#
4# Tcl help command. (see TclX manual)
5#
6#------------------------------------------------------------------------------
7# Copyright 1992 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# $Id: help.tcl,v 2.0 1992/10/16 04:52:01 markd Rel $
17#------------------------------------------------------------------------------
18#
19
20#@package: TclX-help help helpcd helppwd apropos
21
22#------------------------------------------------------------------------------
23# Take a path name which might have . and .. elements and flatten them out.
24
25proc help:flattenPath {pathName} {
26 set newPath {}
27 foreach element [split $pathName /] {
28 if {"$element" == "."} {
29 continue
30 }
31 if {"$element" == ".."} {
32 if {[llength [join $newPath /]] == 0} {
33 error "Help: name goes above subject directory root"}
34 lvarpop newPath [expr [llength $newPath]-1]
35 continue
36 }
37 lappend newPath $element
38 }
39 set newPath [join $newPath /]
40
41 # Take care of the case where we started with something line "/" or "/."
42
43 if {("$newPath" == "") && [string match "/*" $pathName]} {
44 set newPath "/"}
45
46 return $newPath
47}
48
49#------------------------------------------------------------------------------
50# Take the help current directory and a path and evaluate it into a help root-
51# based path name.
52
53proc help:EvalPath {pathName} {
54 global TCLENV
55
56 if {![string match "/*" $pathName]} {
57 if {"$pathName" == ""} {
58 return $TCLENV(help:curDir)}
59 if {"$TCLENV(help:curDir)" == "/"} {
60 set pathName "/$pathName"
61 } else {
62 set pathName "$TCLENV(help:curDir)/$pathName"
63 }
64 }
65 set pathName [help:flattenPath $pathName]
66 if {[string match "*/" $pathName] && ($pathName != "/")} {
67 set pathName [csubstr $pathName 0 [expr [length $pathName]-1]]}
68
69 return $pathName
70}
71
72#------------------------------------------------------------------------------
73# Display a line of output, pausing waiting for input before displaying if the
74# screen size has been reached. Return 1 if output is to continue, return
75# 0 if no more should be outputed, indicated by input other than return.
76#
77
78proc help:Display {line} {
79 global TCLENV
80 if {$TCLENV(help:lineCnt) >= 23} {
81 set TCLENV(help:lineCnt) 0
82 puts stdout ":" nonewline
83 flush stdout
84 gets stdin response
85 if {![lempty $response]} {
86 return 0}
87 }
88 puts stdout $line
89 incr TCLENV(help:lineCnt)
90}
91
92#------------------------------------------------------------------------------
93# Display a file.
94
95proc help:DisplayFile {filepath} {
96
97 set inFH [open $filepath r]
98 while {[gets $inFH fileBuf] >= 0} {
99 if {![help:Display $fileBuf]} {
100 break}
101 }
102 close $inFH
103
104}
105
106#------------------------------------------------------------------------------
107# Procedure to return contents of a directory. A list is returned, consisting
108# of two lists. The first list are all the directories (subjects) in the
109# specified directory. The second is all of the help files. Eash sub-list
110# is sorted in alphabetical order.
111#
112
113proc help:ListDir {dirPath} {
114 set dirList {}
115 set fileList {}
116 if {[catch {set dirFiles [glob $dirPath/*]}] != 0} {
117 error "No files in subject directory: $dirPath"}
118 foreach fileName $dirFiles {
119 if [file isdirectory $fileName] {
120 lappend dirList "[file tail $fileName]/"
121 } else {
122 lappend fileList [file tail $fileName]
123 }
124 }
125 return [list [lsort $dirList] [lsort $fileList]]
126}
127
128#------------------------------------------------------------------------------
129# Display a list of file names in a column format. This use columns of 14
130# characters 3 blanks.
131
132proc help:DisplayColumns {nameList} {
133 set count 0
134 set outLine ""
135 foreach name $nameList {
136 if {$count == 0} {
137 append outLine " "}
138 append outLine $name
139 if {[incr count] < 4} {
140 set padLen [expr 17-[clength $name]]
141 if {$padLen < 3} {
142 set padLen 3}
143 append outLine [replicate " " $padLen]
144 } else {
145 if {![help:Display $outLine]} {
146 return}
147 set outLine ""
148 set count 0
149 }
150 }
151 if {$count != 0} {
152 help:Display $outLine}
153 return
154}
155
156
157#------------------------------------------------------------------------------
158# Help command main.
159
160proc help {{subject {}}} {
161 global TCLENV
162
163 set TCLENV(help:lineCnt) 0
164
165 # Special case "help help", so we can get it at any level.
166
167 if {($subject == "help") || ($subject == "?")} {
168 help:DisplayFile "$TCLENV(help:root)/help"
169 return
170 }
171
172 set request [help:EvalPath $subject]
173 set requestPath "$TCLENV(help:root)$request"
174
175 if {![file exists $requestPath]} {
176 error "Help:\"$request\" does not exist"}
177
178 if [file isdirectory $requestPath] {
179 set dirList [help:ListDir $requestPath]
180 set subList [lindex $dirList 0]
181 set fileList [lindex $dirList 1]
182 if {[llength $subList] != 0} {
183 help:Display "\nSubjects available in $request:"
184 help:DisplayColumns $subList
185 }
186 if {[llength $fileList] != 0} {
187 help:Display "\nHelp files available in $request:"
188 help:DisplayColumns $fileList
189 }
190 } else {
191 help:DisplayFile $requestPath
192 }
193 return
194}
195
196
197#------------------------------------------------------------------------------
198# Helpcd main.
199#
200# The name of the new current directory is assembled from the current
201# directory and the argument. The name will be flatten and any trailing
202# "/" will be removed, unless the name is just "/".
203
204proc helpcd {{dir /}} {
205 global TCLENV
206
207 set request [help:EvalPath $dir]
208 set requestPath "$TCLENV(help:root)$request"
209
210 if {![file exists $requestPath]} {
211 error "Helpcd: \"$request\" does not exist"}
212
213 if {![file isdirectory $requestPath]} {
214 error "Helpcd: \"$request\" is not a directory"}
215
216 set TCLENV(help:curDir) $request
217 return
218}
219
220#------------------------------------------------------------------------------
221# Helpcd main.
222
223proc helppwd {} {
224 global TCLENV
225 echo "Current help subject directory: $TCLENV(help:curDir)"
226}
227
228#==============================================================================
229# Tcl apropos command. (see Tcl shell manual)
230#------------------------------------------------------------------------------
231
232proc apropos {name} {
233 global TCLENV
234
235 set TCLENV(help:lineCnt) 0
236
237 set aproposCT [scancontext create]
238 scanmatch -nocase $aproposCT $name {
239 set path [lindex $matchInfo(line) 0]
240 set desc [lrange $matchInfo(line) 1 end]
241 if {![help:Display [format "%s - %s" $path $desc]]} {
242 return}
243 }
244 foreach brief [glob -nocomplain $TCLENV(help:root)/*.brf] {
245 set briefFH [open $brief]
246 scanfile $aproposCT $briefFH
247 close $briefFH
248 }
249 scancontext delete $aproposCT
250}
251
252#------------------------------------------------------------------------------
253# One time initialization done when the file is sourced.
254#
255global TCLENV TCLPATH
256
257set TCLENV(help:root) [searchpath $TCLPATH help]
258set TCLENV(help:curDir) "/"
259set TCLENV(help:outBuf) {}
Impressum, Datenschutz