![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to help.tcl CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Micropolis - Activity] / micropolis / src / tclx / tclsrc|
Return to help.tcl CVS log | Up to [Micropolis - Activity] / micropolis / src / tclx / tclsrc |
1.1 root 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) {}
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.