home *** CD-ROM | disk | FTP | other *** search
/ Mac-Source 1994 July / Mac-Source_July_1994.iso / Other Langs / Tickle-4.0 (tcl) / tcl / extend / tclsrc / buildhelp.tcl < prev    next >
Encoding:
Text File  |  1993-10-26  |  12.3 KB  |  377 lines  |  [TEXT/MPS ]
  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-1993 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.10 1993/08/31 23:44:51 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 generate help:
  70. #
  71. #   buildhelp helpDir brief.brf filelist
  72. #
  73. # o helpDir is the help tree root directory.  helpDir should  exists, but any
  74. #   subdirectories that don't exists will be created.  helpDir should be
  75. #   cleaned up before the start of manual page generation, as this program
  76. #   will not overwrite existing files.
  77. # o brief.brf  is the name of the brief file to create form the @brief entries.
  78. #   It must have an extension of ".brf".  It will be created in helpDir.
  79. # o filelist are the nroff manual pages, or .tcl, .tlib files to extract
  80. #   the help files from. If the suffix is not .tcl or .tlib, a nroff manual
  81. #   page is assumed.
  82. #
  83. #-----------------------------------------------------------------------------
  84.  
  85. #@package: TclX-buildhelp buildhelp
  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.  
  162.     # The `\\n' become `\n' in the text.
  163.         
  164.     puts $helpFH ".ad b"
  165.     puts $helpFH ".PD"
  166.     puts $helpFH ".nrIN \\n()Mu"
  167.     puts $helpFH ".nr)R 0"
  168.     puts $helpFH ".nr)I \\n()Mu"
  169.     puts $helpFH ".nr)R 0"
  170.     puts $helpFH ".\}E"
  171.     puts $helpFH ".DT"
  172.     puts $helpFH ".hy14"
  173.     puts $helpFH $nroffHeader
  174.     set foundBrief 0
  175.     while {[gets $manPageFH manLine] >= 0} {
  176.         if {[string first "'@endhelp" $manLine] == 0} {
  177.             break;
  178.         }
  179.         if {[string first "'@brief:" $manLine] == 0} {
  180.             if $foundBrief {
  181.                 error {Duplicate "'@brief" entry"}
  182.             }
  183.             set foundBrief 1
  184.         puts $G_briefHelpFH "$helpName\t[csubstr $manLine 8 end]"
  185.             continue;
  186.         }
  187.         if {[string first "'@:" $manLine] == 0} {
  188.             set manLine [csubstr $manLine 3 end]
  189.         }
  190.         if {[string first "'@help" $manLine] == 0} {
  191.             error {"'@help" found within another help section"}
  192.         }
  193.         puts $helpFH $manLine
  194.         }
  195.     close $helpFH
  196.     chmod a-w,a+r $helpFile
  197. }
  198.  
  199. #-----------------------------------------------------------------------------
  200. #
  201. # Proc to extract a tcl script help file when it is located in the text.
  202. #    ScriptPageFH - The file handle of the .tcl file.
  203. #    ScriptLine - The #@help: line starting the data to extract.
  204. #
  205.  
  206. proc ExtractScriptHelp {ScriptPageFH ScriptLine} {
  207.     global G_helpDir G_briefHelpFH
  208.     set helpName [string trim [csubstr $ScriptLine 7 end]]
  209.     set helpFile "$G_helpDir/$helpName"
  210.     if {[file exists $helpFile]} {
  211.         error "Help file already exists: $helpFile"}
  212.     EnsureDirs $helpFile
  213.     set helpFH [open $helpFile w]
  214.     echo "    creating help file $helpName"
  215.     set foundBrief 0
  216.     while {[gets $ScriptPageFH ScriptLine] >= 0} {
  217.         if {[string first "#@endhelp" $ScriptLine] == 0} {
  218.             break;
  219.         }
  220.         if {[string first "#@brief:" $ScriptLine] == 0} {
  221.             if $foundBrief {
  222.                 error {Duplicate "#@brief" entry"}
  223.             }
  224.             set foundBrief 1
  225.         puts $G_briefHelpFH "$helpName\t[csubstr $ScriptLine 8 end]"
  226.             continue;
  227.         }
  228.         if {[string first "#@help" $ScriptLine] == 0} {
  229.             error {"#@help" found within another help section"}
  230.         }
  231.         if {[clength $ScriptLine] > 1} {
  232.             set ScriptLine " [csubstr $ScriptLine 1 end]"
  233.         } else {
  234.             set ScriptLine ""
  235.         }
  236.         puts $helpFH $ScriptLine
  237.         }
  238.     close $helpFH
  239.     chmod a-w,a+r $helpFile
  240. }
  241.  
  242. #-----------------------------------------------------------------------------
  243. #
  244. # Proc to scan a nroff manual file looking for the start of a help text
  245. # sections and extracting those sections.
  246. #    pathName - Full path name of file to extract documentation from.
  247. #
  248.  
  249. proc ProcessNroffFile {pathName} {
  250.    global G_nroffScanCT G_scriptScanCT nroffHeader
  251.  
  252.    set fileName [file tail $pathName]
  253.  
  254.    set nroffHeader {}
  255.    set manPageFH [open $pathName r]
  256.    echo "    scanning $pathName"
  257.    set matchInfo(fileName) [file tail $pathName]
  258.    scanfile $G_nroffScanCT $manPageFH
  259.    close $manPageFH
  260. }
  261.  
  262. #-----------------------------------------------------------------------------
  263. #
  264. # Proc to scan a Tcl script file looking for the start of a
  265. # help text sections and extracting those sections.
  266. #    pathName - Full path name of file to extract documentation from.
  267. #
  268.  
  269. proc ProcessTclScript {pathName} {
  270.    global G_scriptScanCT nroffHeader
  271.  
  272.    set scriptFH [open "$pathName" r]
  273.  
  274.    echo "    scanning $pathName"
  275.    set matchInfo(fileName) [file tail $pathName]
  276.    scanfile $G_scriptScanCT $scriptFH
  277.    close $scriptFH
  278. }
  279.  
  280. #-----------------------------------------------------------------------------
  281. # build: main procedure.  Generates help from specified files.
  282. #    helpDirPath - Directory were the help files go.
  283. #    briefFile - The name of the brief file to create.
  284. #    sourceFiles - List of files to extract help files from.
  285.  
  286. proc buildhelp {helpDirPath briefFile sourceFiles} {
  287.     global G_helpDir G_truncFileNames G_nroffScanCT
  288.     global G_scriptScanCT G_briefHelpFH G_colArgs
  289.  
  290.     echo ""
  291.     echo "Begin building help tree"
  292.  
  293.     # Determine version of col command to use (no -x on BSD)
  294.     if {[system {col -bx </dev/null >/dev/null 2>&1}] != 0} {
  295.         set G_colArgs {-b}
  296.     } else {
  297.         set G_colArgs {-bx}
  298.     }
  299.     set G_helpDir $helpDirPath
  300.     if {![file exists $G_helpDir]} {
  301.         mkdir $G_helpDir
  302.     }
  303.  
  304.     if {![file isdirectory $G_helpDir]} {
  305.         error [concat "$G_helpDir is not a directory or does not exist. "  
  306.                       "This should be the help root directory"]
  307.     }
  308.         
  309.     set status [catch {set tmpFH [open $G_helpDir/AVeryVeryBigFileName w]}]
  310.     if {$status != 0} {
  311.         set G_truncFileNames 1
  312.     } else {
  313.         close $tmpFH
  314.         unlink $G_helpDir/AVeryVeryBigFileName
  315.         set G_truncFileNames 0
  316.     }
  317.  
  318.     set G_nroffScanCT [scancontext create]
  319.  
  320.     scanmatch $G_nroffScanCT "^'@help:" {
  321.         ExtractNroffHelp $matchInfo(handle) $matchInfo(line)
  322.         continue
  323.     }
  324.  
  325.     scanmatch $G_nroffScanCT "^'@header" {
  326.         ExtractNroffHeader $matchInfo(handle)
  327.         continue
  328.     }
  329.     scanmatch $G_nroffScanCT "^'@endhelp" {
  330.         error [concat {"'@endhelp" without corresponding "'@help:"} \
  331.                  ", offset = $matchInfo(offset)"]
  332.     }
  333.     scanmatch $G_nroffScanCT "^'@brief" {
  334.         error [concat {"'@brief" without corresponding "'@help:"} \
  335.                  ", offset = $matchInfo(offset)"]
  336.     }
  337.  
  338.     set G_scriptScanCT [scancontext create]
  339.     scanmatch $G_scriptScanCT "^#@help:" {
  340.         ExtractScriptHelp $matchInfo(handle) $matchInfo(line)
  341.     }
  342.  
  343.     if {[file extension $briefFile] != ".brf"} {
  344.         puts stderr "Brief file \"$briefFile\" must have an extension \".brf\""
  345.         exit 1
  346.     }
  347.     if [file exists $G_helpDir/$briefFile] {
  348.         puts stderr "Brief file \"$G_helpDir/$briefFile\" already exists"
  349.         exit 1
  350.     }
  351.     set G_briefHelpFH [open "|sort > $G_helpDir/$briefFile" w]
  352.  
  353.     foreach manFile $sourceFiles {
  354.         set manFile [glob $manFile]
  355.         set ext [file extension $manFile]
  356.         if {$ext == ".tcl" || $ext == ".tlib"} {
  357.             set status [catch {ProcessTclScript $manFile} msg]
  358.         } else {
  359.             set status [catch {ProcessNroffFile $manFile} msg]
  360.         }
  361.         if {$status != 0} {
  362.             echo "Error extracting help from: $manFile"
  363.             echo $msg
  364.             global errorInfo tcl_interactive
  365.             if {!$tcl_interactive} {
  366.                 echo $errorInfo
  367.                 exit 1
  368.             }
  369.         }
  370.     }
  371.  
  372.     close $G_briefHelpFH
  373.     chmod a-w,a+r $G_helpDir/$briefFile
  374.     echo "Completed extraction of help files"
  375. }
  376.  
  377.