git.zerfleddert.de Git - micropolis/blob - src/tclx/tcllib/buildhelp.tcl

   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 }