![[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.