tclx/library/buildhelp.tcl

#
# buildhelp.tcl --
#
# Program to extract help files from TCL manual pages or TCL script files.
# The help directories are built as a hierarchical tree of subjects and help
# files.
#
#------------------------------------------------------------------------------
# Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans.
#
# Permission to use, copy, modify, and distribute this software and its
# documentation for any purpose and without fee is hereby granted, provided
# that the above copyright notice appear in all copies.  Karl Lehenbauer and
# Mark Diekhans make no representations about the suitability of this
# software for any purpose.  It is provided "as is" without express or
# implied warranty.
#------------------------------------------------------------------------------
# $Id: buildhelp.tcl,v 1.3 2005/03/25 19:32:48 hobbs Exp $
#------------------------------------------------------------------------------
#
# For nroff man pages, the areas of text to extract are delimited with:
#
#     '\"@help: subjectdir/helpfile
#     '\"@endhelp
#
# start in column one. The text between these markers is extracted and stored
# in help/subjectdir/help.  The file must not exists, this is done to enforced
# cleaning out the directories before help file generation is started, thus
# removing any stale files.  The extracted text is run through:
#
#     nroff -man|col -xb   {col -b on BSD derived systems}
#
# If there is other text to include in the helpfile, but not in the manual
# page, the text, along with nroff formatting commands, may be included using:
#
#     '\"@:Other text to include in the help page.
#
# A entry in the brief file, used by apropos my be included by:
#
#     '\"@brief: Short, one line description
#
# These brief request must occur with in the bounds of a help section.
#
# If some header text, such as nroff macros, need to be preappended to the
# text streem before it is run through nroff, then that text can be bracketed
# with:
#
#     '\"@header
#     '\"@endheader
#
# If multiple header blocks are encountered, they will all be preappended.
#
# For TCL script files, which are indentified because they end in ".tcl",
# the text to be extracted is delimited by:
#
#    #@help: subjectdir/helpfile
#    #@endhelp
#
# And brief lines are in the form:
#
#     #@brief: Short, one line description
#
# The only processing done on text extracted from .tcl files it to replace
# the # in column one with a space.
#
#
#-----------------------------------------------------------------------------
#
# To generate help:
#
#   buildhelp helpDir brief.brf filelist
#
# o helpDir is the help tree root directory.  helpDir should  exists, but any
#   subdirectories that don't exists will be created.  helpDir should be
#   cleaned up before the start of manual page generation, as this program
#   will not overwrite existing files.
# o brief.brf  is the name of the brief file to create form the @brief entries.
#   It must have an extension of ".brf".  It will be created in helpDir.
# o filelist are the nroff manual pages, or .tcl, .tlib files to extract
#   the help files from. If the suffix is not .tcl or .tlib, a nroff manual
#   page is assumed.
#
#-----------------------------------------------------------------------------

#@package: TclX-buildhelp buildhelp

#-----------------------------------------------------------------------------
# Truncate a file name of a help file if the system does not support long
# file names.  If the name starts with `Tcl_', then this prefix is removed.
# If the name is then over 14 characters, it is truncated to 14 charactes
#
proc TruncFileName {pathName} {
    global truncFileNames

    if {!$truncFileNames} {
        return $pathName}
    set fileName [file tail $pathName]
    if {"[crange $fileName 0 3]" == "Tcl_"} {
        set fileName [crange $fileName 4 end]}
    set fileName [crange $fileName 0 13]
    return "[file dirname $pathName]/$fileName"
}

#-----------------------------------------------------------------------------
# Proc to ensure that all directories for the specified file path exists,
# and if they don't create them.  Don't use -path so we can set the
# permissions.

proc EnsureDirs {filePath} {
    set dirPath [file dirname $filePath]
    if [file exists $dirPath] return
    foreach dir [split $dirPath /] {
        lappend dirList $dir
        set partPath [join $dirList /]
        if [file exists $partPath] continue

        mkdir $partPath
        chmod u=rwx,go=rx $partPath
    }
}

#-----------------------------------------------------------------------------
# Proc to set up scan context for use by FilterNroffManPage.
# This keeps the a two line cache of the previous two lines encountered
# and the blank lines that followed them.
#

proc CreateFilterNroffManPageContext {} {
    global filterNroffManPageContext

    set filterNroffManPageContext [scancontext create]

    # On finding a page header, drop the previous line (which is
    # the page footer). Also deleting the blank lines followin
    # the last line on the previous page.

    scanmatch $filterNroffManPageContext {@@@BUILDHELP@@@} {
        catch {unset prev2Blanks}
        catch {unset prev1Line}
        catch {unset prev1Blanks}
        set nukeBlanks {}
    }

    # Save blank lines

    scanmatch $filterNroffManPageContext {$^} {
        if ![info exists nukeBlanks] {
            append prev1Blanks \n
        }
    }

    # Non-blank line, save it.  Output the 2nd previous line if necessary.

    scanmatch $filterNroffManPageContext {
        catch {unset nukeBlanks}
        if [info exists prev2Line] {
            puts $outFH $prev2Line
            unset prev2Line
        }
        if [info exists prev2Blanks] {
            puts $outFH $prev2Blanks nonewline
            unset prev2Blanks
        }
        if [info exists prev1Line] {
            set prev2Line $prev1Line
        }
        set prev1Line $matchInfo(line)
        if [info exists prev1Blanks] {
            set prev2Blanks $prev1Blanks
            unset prev1Blanks
        }
    }
}

#-----------------------------------------------------------------------------
# Proc to filter a formatted manual page, removing the page headers and
# footers.  This relies on each manual page having a .TH macro in the form:
#   .TH @@@BUILDHELP@@@ n

proc FilterNroffManPage {inFH outFH} {
    global filterNroffManPageContext

    if ![info exists filterNroffManPageContext] {
        CreateFilterNroffManPageContext
    }

    scanfile $filterNroffManPageContext $inFH

    if [info exists prev2Line] {
        puts $outFH $prev2Line
    }
}

#-----------------------------------------------------------------------------
# Proc to set up scan context for use by ExtractNroffHeader
#

proc CreateExtractNroffHeaderContext {} {
    global extractNroffHeaderContext

    set extractNroffHeaderContext [scancontext create]

    scanmatch $extractNroffHeaderContext {'\\"@endheader[ 	]*$} {
        break
    }
    scanmatch $extractNroffHeaderContext {'\\"@:} {
        append nroffHeader "[crange $matchInfo(line) 5 end]\n"
    }
    scanmatch $extractNroffHeaderContext {
        append nroffHeader "$matchInfo(line)\n"
    }
}

#-----------------------------------------------------------------------------
# Proc to extract nroff text to use as a header to all pass to nroff when
# processing a help file.
#    manPageFH - The file handle of the manual page.
#

proc ExtractNroffHeader {manPageFH} {
    global extractNroffHeaderContext nroffHeader

    if ![info exists extractNroffHeaderContext] {
        CreateExtractNroffHeaderContext
    }
    scanfile $extractNroffHeaderContext $manPageFH
}


#-----------------------------------------------------------------------------
# Proc to set up scan context for use by ExtractNroffHelp
#

proc CreateExtractNroffHelpContext {} {
    global extractNroffHelpContext

    set extractNroffHelpContext [scancontext create]

    scanmatch $extractNroffHelpContext {^'\\"@endhelp[ 	]*$} {
        break
    }

    scanmatch $extractNroffHelpContext {^'\\"@brief:} {
        if $foundBrief {
            error {Duplicate "@brief:" entry}
        }
        set foundBrief 1
        puts $briefHelpFH "$helpName\t[csubstr $matchInfo(line) 11 end]"
        continue
    }

    scanmatch $extractNroffHelpContext {^'\\"@:} {
        puts $nroffFH  [csubstr $matchInfo(line) 5 end]
        continue
    }
    scanmatch $extractNroffHelpContext {^'\\"@help:} {
        error {"@help" found within another help section"}
    }
    scanmatch $extractNroffHelpContext {
        puts $nroffFH $matchInfo(line)
    }
}

#-----------------------------------------------------------------------------
# Proc to extract a nroff help file when it is located in the text.
#    manPageFH - The file handle of the manual page.
#    manLine - The '\"@help: line starting the data to extract.
#

proc ExtractNroffHelp {manPageFH manLine} {
    global helpDir nroffHeader briefHelpFH colArgs
    global extractNroffHelpContext

    if ![info exists extractNroffHelpContext] {
        CreateExtractNroffHelpContext
    }

    set helpName [string trim [csubstr $manLine 9 end]]
    set helpFile [TruncFileName "$helpDir/$helpName"]
    if [file exists $helpFile] {
        error "Help file already exists: $helpFile"
    }
    EnsureDirs $helpFile

    set tmpFile "[file dirname $helpFile]/tmp.[id process]"

    echo "    creating help file $helpName"

    set nroffFH [open "| nroff -man | col $colArgs > $tmpFile" w]

    puts $nroffFH {.TH @@@BUILDHELP@@@ 1}

    set foundBrief 0
    scanfile $extractNroffHelpContext $manPageFH

    # Close returns an error on if anything comes back on stderr, even if
    # its a warning.  Output errors and continue.

    set stat [catch {
        close $nroffFH
    } msg]
    if $stat {
        puts stderr "nroff: $msg"
    }

    set tmpFH [open $tmpFile r]
    set helpFH [open $helpFile w]

    FilterNroffManPage $tmpFH $helpFH

    close $tmpFH
    close $helpFH

    unlink $tmpFile
    chmod a-w,a+r $helpFile
}

#-----------------------------------------------------------------------------
# Proc to set up scan context for use by ExtractScriptHelp
#

proc CreateExtractScriptHelpContext {} {
    global extractScriptHelpContext

    set extractScriptHelpContext [scancontext create]

    scanmatch $extractScriptHelpContext {^#@endhelp[ 	]*$} {
        break
    }

    scanmatch $extractScriptHelpContext {^#@brief:} {
        if $foundBrief {
            error {Duplicate "@brief" entry}
        }
        set foundBrief 1
        puts $briefHelpFH "$helpName\t[csubstr $matchInfo(line) 9 end]"
        continue
    }

    scanmatch $extractScriptHelpContext {^#@help:} {
        error {"@help" found within another help section"}
    }

    scanmatch $extractScriptHelpContext {^#$} {
        puts $helpFH ""
    }

    scanmatch $extractScriptHelpContext {
        if {[clength $matchInfo(line)] > 1} {
            puts $helpFH " [csubstr $matchInfo(line) 1 end]"
        } else {
            puts $helpFH $matchInfo(line)
        }
    }
}

#-----------------------------------------------------------------------------
# Proc to extract a tcl script help file when it is located in the text.
#    ScriptPageFH - The file handle of the .tcl file.
#    ScriptLine - The #@help: line starting the data to extract.
#

proc ExtractScriptHelp {scriptPageFH scriptLine} {
    global helpDir briefHelpFH
    global extractScriptHelpContext

    if ![info exists extractScriptHelpContext] {
        CreateExtractScriptHelpContext
    }

    set helpName [string trim [csubstr $scriptLine 7 end]]
    set helpFile "$helpDir/$helpName"
    if {[file exists $helpFile]} {
        error "Help file already exists: $helpFile"
    }
    EnsureDirs $helpFile

    echo "    creating help file $helpName"

    set helpFH [open $helpFile w]

    set foundBrief 0
    scanfile $extractScriptHelpContext $scriptPageFH

    close $helpFH
    chmod a-w,a+r $helpFile
}

#-----------------------------------------------------------------------------
# Proc to scan a nroff manual file looking for the start of a help text
# sections and extracting those sections.
#    pathName - Full path name of file to extract documentation from.
#

proc ProcessNroffFile {pathName} {
   global nroffScanCT scriptScanCT nroffHeader

   set fileName [file tail $pathName]

   set nroffHeader {}
   set manPageFH [open $pathName r]
   set matchInfo(fileName) [file tail $pathName]

   echo "    scanning $pathName"

   scanfile $nroffScanCT $manPageFH

   close $manPageFH
}

#-----------------------------------------------------------------------------
# Proc to scan a Tcl script file looking for the start of a
# help text sections and extracting those sections.
#    pathName - Full path name of file to extract documentation from.
#

proc ProcessTclScript {pathName} {
   global scriptScanCT nroffHeader

   set scriptFH [open "$pathName" r]
   set matchInfo(fileName) [file tail $pathName]

   echo "    scanning $pathName"
   scanfile $scriptScanCT $scriptFH

   close $scriptFH
}

#-----------------------------------------------------------------------------
# build: main procedure.  Generates help from specified files.
#    helpDirPath - Directory were the help files go.
#    briefFile - The name of the brief file to create.
#    sourceFiles - List of files to extract help files from.

proc buildhelp {helpDirPath briefFile sourceFiles} {
    global helpDir truncFileNames nroffScanCT
    global scriptScanCT briefHelpFH colArgs

    echo ""
    echo "Begin building help tree"

    # Determine version of col command to use (no -x on BSD)
    if {[catch {exec col -bx </dev/null >/dev/null 2>/dev/null}]} {
        set colArgs {-b}
    } else {
        set colArgs {-bx}
    }
    set helpDir $helpDirPath
    if {![file exists $helpDir]} {
        mkdir $helpDir
    }

    if {![file isdirectory $helpDir]} {
        error "$helpDir is not a directory or does not exist.\n \
                      This should be the help root directory"
    }

    set status [catch {set tmpFH [open $helpDir/AVeryVeryBigFileName w]}]
    if {$status != 0} {
        set truncFileNames 1
    } else {
        close $tmpFH
        unlink $helpDir/AVeryVeryBigFileName
        set truncFileNames 0
    }

    set nroffScanCT [scancontext create]

    scanmatch $nroffScanCT {'\\"@help:} {
        ExtractNroffHelp $matchInfo(handle) $matchInfo(line)
        continue
    }

    scanmatch $nroffScanCT {^'\\"@header} {
        ExtractNroffHeader $matchInfo(handle)
        continue
    }
    scanmatch $nroffScanCT {^'\\"@endhelp} {
        error [concat {@endhelp" without corresponding "@help:"} \
                 ", offset = $matchInfo(offset)"]
    }
    scanmatch $nroffScanCT {^'\\"@brief} {
        error [concat {"@brief" without corresponding "@help:"} \
                 ", offset = $matchInfo(offset)"]
    }

    set scriptScanCT [scancontext create]
    scanmatch $scriptScanCT {^#@help:} {
        ExtractScriptHelp $matchInfo(handle) $matchInfo(line)
    }

    if {[file extension $briefFile] != ".brf"} {
        error "Brief file \"$briefFile\" must have an extension \".brf\""
    }
    if [file exists $helpDir/$briefFile] {
        error "Brief file \"$helpDir/$briefFile\" already exists"
    }
    set briefHelpFH [open "|sort > $helpDir/$briefFile" w]

    foreach manFile [glob $sourceFiles] {
        set ext [file extension $manFile]
        if {$ext == ".tcl" || $ext == ".tlib"} {
            set status [catch {ProcessTclScript $manFile} msg]
        } else {
            set status [catch {ProcessNroffFile $manFile} msg]
        }
        if {$status != 0} {
            global errorInfo errorCode
            error "Error extracting help from: $manFile" $errorInfo $errorCode
        }
    }

    close $briefHelpFH
    chmod a-w,a+r $helpDir/$briefFile
    echo "Completed extraction of help files"
}