![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to buildhelp.tcl CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Micropolis - Activity] / micropolis / src / tclx / tcllib|
Return to buildhelp.tcl CVS log | Up to [Micropolis - Activity] / micropolis / src / tclx / tcllib |
1.1 root 1: #
2: # buildhelp.tcl --
3: #
4: # Program to extract help files from TCL manual pages or TCL script files.
5: # The help directories are built as a hierarchical tree of subjects and help
6: # files.
7: #
8: #------------------------------------------------------------------------------
9: # Copyright 1992 Karl Lehenbauer and Mark Diekhans.
10: #
11: # Permission to use, copy, modify, and distribute this software and its
12: # documentation for any purpose and without fee is hereby granted, provided
13: # that the above copyright notice appear in all copies. Karl Lehenbauer and
14: # Mark Diekhans make no representations about the suitability of this
15: # software for any purpose. It is provided "as is" without express or
16: # implied warranty.
17: #------------------------------------------------------------------------------
18: # $Id: buildhelp.tcl,v 2.1 1992/10/25 17:07:40 markd Exp $
19: #------------------------------------------------------------------------------
20: #
21: # For nroff man pages, the areas of text to extract are delimited with:
22: #
23: # '@help: subjectdir/helpfile
24: # '@endhelp
25: #
26: # start in column one. The text between these markers is extracted and stored
27: # in help/subjectdir/help. The file must not exists, this is done to enforced
28: # cleaning out the directories before help file generation is started, thus
29: # removing any stale files. The extracted text is run through:
30: #
31: # nroff -man|col -xb {col -b on BSD derived systems}
32: #
33: # If there is other text to include in the helpfile, but not in the manual
34: # page, the text, along with nroff formatting commands, may be included using:
35: #
36: # '@:Other text to include in the help page.
37: #
38: # A entry in the brief file, used by apropos my be included by:
39: #
40: # '@brief: Short, one line description
41: #
42: # These brief request must occur with in the bounds of a help section.
43: #
44: # If some header text, such as nroff macros, need to be preappended to the
45: # text streem before it is run through nroff, then that text can be bracketed
46: # with:
47: #
48: # '@header
49: # '@endheader
50: #
51: # If multiple header blocks are encountered, they will all be preappended.
52: #
53: # For TCL script files, which are indentified because they end in ".tcl",
54: # the text to be extracted is delimited by:
55: #
56: # #@help: subjectdir/helpfile
57: # #@endhelp
58: #
59: # And brief lines are in the form:
60: #
61: # #@brief: Short, one line description
62: #
63: # The only processing done on text extracted from .tcl files it to replace
64: # the # in column one with a space.
65: #
66: #
67: #-----------------------------------------------------------------------------
68: #
69: # To run this program:
70: #
71: # tcl buildhelp.tcl [-m mergeTree] -b brief.brf helpDir file-1 file-2 ...
72: #
73: # o -m mergeTree is a tree of help code, plus a brief file to merge with the
74: # help files that are to be extracted. This will become part of the new
75: # help tree. Used to merge in the documentation from UCB Tcl.
76: # o -b specified the name of the brief file to create form the @brief entries.
77: # It must have an extension of ".brf".
78: # o helpDir is the help tree root directory. helpDir should exists, but any
79: # subdirectories that don't exists will be created. helpDir should be
80: # cleaned up before the start of manual page generation, as this program
81: # will not overwrite existing files.
82: # o file-n are the nroff manual pages (.man) or .tcl or .tlib files to extract
83: # the help files from.
84: #
85: #-----------------------------------------------------------------------------
86:
87: #-----------------------------------------------------------------------------
88: # Truncate a file name of a help file if the system does not support long
89: # file names. If the name starts with `Tcl_', then this prefix is removed.
90: # If the name is then over 14 characters, it is truncated to 14 charactes
91: #
92: proc TruncFileName {pathName} {
93: global G_truncFileNames
94:
95: if {!$G_truncFileNames} {
96: return $pathName}
97: set fileName [file tail $pathName]
98: if {"[crange $fileName 0 3]" == "Tcl_"} {
99: set fileName [crange $fileName 4 end]}
100: set fileName [crange $fileName 0 13]
101: return "[file dirname $pathName]/$fileName"
102: }
103:
104: #-----------------------------------------------------------------------------
105: # Proc to ensure that all directories for the specified file path exists,
106: # and if they don't create them. Don't use -path so we can set the
107: # permissions.
108:
109: proc EnsureDirs {filePath} {
110: set dirPath [file dirname $filePath]
111: if [file exists $dirPath] return
112: foreach dir [split $dirPath /] {
113: lappend dirList $dir
114: set partPath [join $dirList /]
115: if [file exists $partPath] continue
116:
117: mkdir $partPath
118: chmod u=rwx,go=rx $partPath
119: }
120: }
121:
122:
123: #-----------------------------------------------------------------------------
124: #
125: # Proc to extract nroff text to use as a header to all pass to nroff when
126: # processing a help file.
127: # manPageFH - The file handle of the manual page.
128: #
129:
130: proc ExtractNroffHeader {manPageFH} {
131: global nroffHeader
132: while {[gets $manPageFH manLine] >= 0} {
133: if {[string first "'@endheader" $manLine] == 0} {
134: break;
135: }
136: if {[string first "'@:" $manLine] == 0} {
137: set manLine [csubstr manLine 3 end]
138: }
139: append nroffHeader "$manLine\n"
140: }
141: }
142:
143: #-----------------------------------------------------------------------------
144: #
145: # Proc to extract a nroff help file when it is located in the text.
146: # manPageFH - The file handle of the manual page.
147: # manLine - The '@help: line starting the data to extract.
148: #
149:
150: proc ExtractNroffHelp {manPageFH manLine} {
151: global G_helpDir nroffHeader G_briefHelpFH G_colArgs
152:
153: set helpName [string trim [csubstr $manLine 7 end]]
154: set helpFile [TruncFileName "$G_helpDir/$helpName"]
155: if {[file exists $helpFile]} {
156: error "Help file already exists: $helpFile"}
157: EnsureDirs $helpFile
158: set helpFH [open "| nroff -man | col $G_colArgs > $helpFile" w]
159: echo " creating help file $helpName"
160:
161: # Nroff commands from .TH macro to get the formatting right. The `\n'
162: # are newline separators to output, the `\\n' become `\n' in the text.
163:
164: puts $helpFH ".ad b\n.PD\n.nrIN \\n()Mu\n.nr)R 0\n.nr)I \\n()Mu"
165: puts $helpFH ".nr)R 0\n.\}E\n.DT\n.na\n.nh"
166: puts $helpFH $nroffHeader
167: set foundBrief 0
168: while {[gets $manPageFH manLine] >= 0} {
169: if {[string first "'@endhelp" $manLine] == 0} {
170: break;
171: }
172: if {[string first "'@brief:" $manLine] == 0} {
173: if $foundBrief {
174: error {Duplicate "'@brief" entry"}
175: }
176: set foundBrief 1
177: puts $G_briefHelpFH "$helpName\t[csubstr $manLine 8 end]"
178: continue;
179: }
180: if {[string first "'@:" $manLine] == 0} {
181: set manLine [csubstr $manLine 3 end]
182: }
183: if {[string first "'@help" $manLine] == 0} {
184: error {"'@help" found within another help section"}
185: }
186: puts $helpFH $manLine
187: }
188: close $helpFH
189: chmod a-w,a+r $helpFile
190: }
191:
192: #-----------------------------------------------------------------------------
193: #
194: # Proc to extract a tcl script help file when it is located in the text.
195: # ScriptPageFH - The file handle of the .tcl file.
196: # ScriptLine - The #@help: line starting the data to extract.
197: #
198:
199: proc ExtractScriptHelp {ScriptPageFH ScriptLine} {
200: global G_helpDir G_briefHelpFH
201: set helpName [string trim [csubstr $ScriptLine 7 end]]
202: set helpFile "$G_helpDir/$helpName"
203: if {[file exists $helpFile]} {
204: error "Help file already exists: $helpFile"}
205: EnsureDirs $helpFile
206: set helpFH [open $helpFile w]
207: echo " creating help file $helpName"
208: set foundBrief 0
209: while {[gets $ScriptPageFH ScriptLine] >= 0} {
210: if {[string first "#@endhelp" $ScriptLine] == 0} {
211: break;
212: }
213: if {[string first "#@brief:" $ScriptLine] == 0} {
214: if $foundBrief {
215: error {Duplicate "#@brief" entry"}
216: }
217: set foundBrief 1
218: puts $G_briefHelpFH "$helpName\t[csubstr $ScriptLine 8 end]"
219: continue;
220: }
221: if {[string first "#@help" $ScriptLine] == 0} {
222: error {"#@help" found within another help section"}
223: }
224: if {[clength $ScriptLine] > 1} {
225: set ScriptLine " [csubstr $ScriptLine 1 end]"
226: } else {
227: set ScriptLine ""
228: }
229: puts $helpFH $ScriptLine
230: }
231: close $helpFH
232: chmod a-w,a+r $helpFile
233: }
234:
235: #-----------------------------------------------------------------------------
236: #
237: # Proc to scan a nroff manual file looking for the start of a help text
238: # sections and extracting those sections.
239: # pathName - Full path name of file to extract documentation from.
240: #
241:
242: proc ProcessNroffFile {pathName} {
243: global G_nroffScanCT G_scriptScanCT nroffHeader
244:
245: set fileName [file tail $pathName]
246:
247: set nroffHeader {}
248: set manPageFH [open $pathName r]
249: echo " scanning $pathName"
250: set matchInfo(fileName) [file tail $pathName]
251: scanfile $G_nroffScanCT $manPageFH
252: close $manPageFH
253: }
254:
255: #-----------------------------------------------------------------------------
256: #
257: # Proc to scan a Tcl script file looking for the start of a
258: # help text sections and extracting those sections.
259: # pathName - Full path name of file to extract documentation from.
260: #
261:
262: proc ProcessTclScript {pathName} {
263: global G_scriptScanCT nroffHeader
264:
265: set scriptFH [open "$pathName" r]
266:
267: echo " scanning $pathName"
268: set matchInfo(fileName) [file tail $pathName]
269: scanfile $G_scriptScanCT $scriptFH
270: close $scriptFH
271: }
272:
273: #-----------------------------------------------------------------------------
274: # Proc to copy the help merge tree, excluding the brief file and RCS files
275: #
276:
277: proc CopyMergeTree {helpDirPath mergeTree} {
278: if {"[cindex $helpDirPath 0]" != "/"} {
279: set helpDirPath "[pwd]/$helpDirPath"
280: }
281: set oldDir [pwd]
282: cd $mergeTree
283:
284: set curHelpDir "."
285:
286: for_recursive_glob mergeFile {.} {
287: if [string match "*/RCS/*" $mergeFile] continue
288:
289: set helpFile "$helpDirPath/$mergeFile"
290: if [file isdirectory $mergeFile] continue
291:
292: if {[file exists $helpFile]} {
293: error "Help file already exists: $helpFile"}
294: EnsureDirs $helpFile
295: set inFH [open $mergeFile r]
296: set outFH [open $helpFile w]
297: copyfile $inFH $outFH
298: close $outFH
299: close $inFH
300: chmod a-w,a+r $helpFile
301: }
302: cd $oldDir
303: }
304:
305: #-----------------------------------------------------------------------------
306: # GenerateHelp: main procedure. Generates help from specified files.
307: # helpDirPath - Directory were the help files go.
308: # mergeTree - Help file tree to merge with the extracted help files.
309: # briefFile - The name of the brief file to create.
310: # sourceFiles - List of files to extract help files from.
311:
312: proc GenerateHelp {helpDirPath briefFile mergeTree sourceFiles} {
313: global G_helpDir G_truncFileNames G_nroffScanCT
314: global G_scriptScanCT G_briefHelpFH G_colArgs
315:
316: echo ""
317: echo "Begin building help tree"
318:
319: # Determine version of col command to use (no -x on BSD)
320: if {[system {col -bx </dev/null >/dev/null 2>&1}] != 0} {
321: set G_colArgs {-b}
322: } else {
323: set G_colArgs {-bx}
324: }
325: set G_helpDir [glob $helpDirPath]
326:
327: if {![file isdirectory $G_helpDir]} {
328: error [concat "$G_helpDir is not a directory or does not exist. "
329: "This should be the help root directory"]
330: }
331:
332: set status [catch {set tmpFH [open $G_helpDir/AVeryVeryBigFileName w]}]
333: if {$status != 0} {
334: set G_truncFileNames 1
335: } else {
336: close $tmpFH
337: unlink $G_helpDir/AVeryVeryBigFileName
338: set G_truncFileNames 0
339: }
340:
341: set G_nroffScanCT [scancontext create]
342:
343: scanmatch $G_nroffScanCT "^'@help:" {
344: ExtractNroffHelp $matchInfo(handle) $matchInfo(line)
345: continue
346: }
347:
348: scanmatch $G_nroffScanCT "^'@header" {
349: ExtractNroffHeader $matchInfo(handle)
350: continue
351: }
352: scanmatch $G_nroffScanCT "^'@endhelp" {
353: error [concat {"'@endhelp" without corresponding "'@help:"} \
354: ", offset = $matchInfo(offset)"]
355: }
356: scanmatch $G_nroffScanCT "^'@brief" {
357: error [concat {"'@brief" without corresponding "'@help:"}
358: ", offset = $matchInfo(offset)"]
359: }
360:
361: set G_scriptScanCT [scancontext create]
362: scanmatch $G_scriptScanCT "^#@help:" {
363: ExtractScriptHelp $matchInfo(handle) $matchInfo(line)
364: }
365:
366: if ![lempty $mergeTree] {
367: echo " Merging tree: $mergeTree"
368: CopyMergeTree $helpDirPath $mergeTree
369: }
370:
371:
372: if {[file extension $briefFile] != ".brf"} {
373: puts stderr "Brief file \"$briefFile\" must have an extension \".brf\""
374: exit 1
375: }
376: if [file exists $G_helpDir/$briefFile] {
377: puts stderr "Brief file \"$G_helpDir/$briefFile\" already exists"
378: exit 1
379: }
380: set G_briefHelpFH [open "|sort > $G_helpDir/$briefFile" w]
381:
382: foreach manFile $sourceFiles {
383: set manFile [glob $manFile]
384: set ext [file extension $manFile]
385: if {"$ext" == ".man"} {
386: set status [catch {ProcessNroffFile $manFile} msg]
387: } else {
388: set status [catch {ProcessTclScript $manFile} msg]
389: }
390: if {$status != 0} {
391: echo "Error extracting help from: $manFile"
392: echo $msg
393: global errorInfo interactiveSession
394: if {!$interactiveSession} {
395: echo $errorInfo
396: exit 1
397: }
398: }
399: }
400:
401: close $G_briefHelpFH
402: chmod a-w,a+r $G_helpDir/$briefFile
403: echo "*** completed extraction of all help files"
404: }
405:
406: #-----------------------------------------------------------------------------
407: # Print a usage message and exit the program
408: proc Usage {} {
409: puts stderr {Wrong args: [-m mergetree] -b briefFile helpdir manfile1 [manfile2..]}
410: exit 1
411: }
412:
413: #-----------------------------------------------------------------------------
414: # Main program body, decides if help is interactive or batch.
415:
416: if {$interactiveSession} {
417: echo "To extract help, use the command:"
418: echo {GenerateHelp helpdir -m mergetree file-1 file-2 ...}
419: } else {
420: set mergeTree {}
421: set briefFile {}
422: while {[string match "-*" [lindex $argv 0]]} {
423: set flag [lvarpop argv 0]
424: case $flag in {
425: "-m" {set mergeTree [lvarpop argv]}
426: "-b" {set briefFile [lvarpop argv]}
427: default Usage
428: }
429: }
430: if {[llength $argv] < 2} {
431: Usage
432: }
433: if [lempty $briefFile] {
434: puts stderr {must specify -b argument}
435: Usage
436: }
437: GenerateHelp [lindex $argv 0] $briefFile $mergeTree [lrange $argv 1 end]
438:
439: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.