]> git.zerfleddert.de Git - micropolis/blob - src/tclx/tclsrc/help.tcl
src/tk/tkevent.c: Micropolis build fixes for recent macOS
[micropolis] / src / tclx / tclsrc / help.tcl
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
25 proc 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
53 proc 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
78 proc 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
95 proc 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
113 proc 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
132 proc 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
160 proc 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
204 proc 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
223 proc 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
232 proc 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 #
255 global TCLENV TCLPATH
256
257 set TCLENV(help:root) [searchpath $TCLPATH help]
258 set TCLENV(help:curDir) "/"
259 set TCLENV(help:outBuf) {}
Impressum, Datenschutz