source: downloads/tcl8.5.2/tools/man2help2.tcl @ 25

# man2help2.tcl --
#
# This file defines procedures that are used during the second pass of
# the man page conversion.  It converts the man format input to rtf
# form suitable for use by the Windows help compiler.
#
# Copyright (c) 1996 by Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: man2help2.tcl,v 1.17 2007/12/13 15:28:40 dgp Exp $
# 

# Global variables used by these scripts:
#
# state -       state variable that controls action of text proc.
#                               
# topics -      array indexed by (package,section,topic) with value
#               of topic ID.
#
# keywords -    array indexed by keyword string with value of topic ID.
#
# curID -       current topic ID, starts at 0 and is incremented for
#               each new topic file.
#
# curPkg -      current package name (e.g. Tcl).
#
# curSect -     current section title (e.g. "Tcl Built-In Commands").
#

# initGlobals --
#
# This procedure is invoked to set the initial values of all of the
# global variables, before processing a man page.
#
# Arguments:
# None.

proc initGlobals {} {
    uplevel \#0 unset state
    global state chars

    set state(paragraphPending) 0
    set state(breakPending) 0
    set state(firstIndent) 0
    set state(leftIndent) 0

    set state(inTP) 0
    set state(paragraph) 0
    set state(textState) 0
    set state(curFont) ""
    set state(startCode) "{\\b "
    set state(startEmphasis) "{\\i "
    set state(endCode) "}"
    set state(endEmphasis) "}"
    set state(noFill) 0
    set state(charCnt) 0
    set state(offset) [getTwips 0.5i]
    set state(leftMargin) [getTwips 0.5i]
    set state(nestingLevel) 0
    set state(intl) 0
    set state(sb) 0
    setTabs 0.5i

# set up international character table

    array set chars {
        o^ F4
    }
}


# beginFont --
#
# Arranges for future text to use a special font, rather than
# the default paragraph font.
#
# Arguments:
# font -                Name of new font to use.

proc beginFont {font} {
    global file state

    textSetup
    if {[string equal $state(curFont) $font]} {
        return
    }
    endFont
    puts -nonewline $file $state(start$font)
    set state(curFont) $font
}


# endFont --
#
# Reverts to the default font for the paragraph type.
#
# Arguments:
# None.

proc endFont {} {
    global state file

    if {[string compare $state(curFont) ""]} {
        puts -nonewline $file $state(end$state(curFont))
        set state(curFont) ""
    }
}


# textSetup --
#
# This procedure is called the first time that text is output for a
# paragraph.  It outputs the header information for the paragraph.
#
# Arguments:
# None.

proc textSetup {} {
    global file state

    if $state(breakPending) {
        puts $file "\\line"
    }
    if $state(paragraphPending) {
        puts $file [format "\\par\n\\pard\\fi%.0f\\li%.0f" \
                        $state(firstIndent) $state(leftIndent)]
        foreach tab $state(tabs) {
            puts $file [format "\\tx%.0f" $tab]
        }
        set state(tabs) {}
        if {$state(sb)} {
            puts $file "\\sb$state(sb)"
            set state(sb) 0
        }
    }
    set state(breakPending) 0
    set state(paragraphPending) 0
}


# text --
#
# This procedure adds text to the current state(paragraph).  If this is
# the first text in the state(paragraph) then header information for the
# state(paragraph) is output before the text.
#
# Arguments:
# string -              Text to output in the state(paragraph).

proc text {string} {
    global file state chars

    textSetup
    set string [string map [list \
            "\\"        "\\\\" \
            "\{"        "\\\{" \
            "\}"        "\\\}" \
            "\t"        {\tab } \
            ''          "\\rdblquote " \
            ``          "\\ldblquote " \
            "\u00b7"    "\\bullet " \
            ] $string]

    # Check if this is the beginning of an international character string.
    # If so, look up the sequence in the chars table and substitute the
    # appropriate hex value.

    if {$state(intl)} {
        if {[regexp {^'([^']*)'} $string dummy ch]} {
            if {[info exists chars($ch)]} {
                regsub {^'[^']*'} $string "\\\\'$chars($ch)" string
            } else {
                puts stderr "Unknown international character '$ch'"
            }
        }
        set state(intl) 0
    }

    switch $state(textState) {
        REF { 
            if {$state(inTP) == 0} {
                set string [insertRef $string]
            }
        }
        SEE { 
            global topics curPkg curSect
            foreach i [split $string] {
                if {![regexp -nocase {^[a-z_0-9]+} [string trim $i] i ]} {
                    continue
                }
                if {![catch {set ref $topics($curPkg,$curSect,$i)} ]} {
                    regsub $i $string [link $i $ref] string
                }
            }
        }
        KEY {
            return
        }
    }
    puts -nonewline $file "$string"
}



# insertRef --
#
# This procedure looks for a string in the cross reference table and
# generates a hot-link to the appropriate topic.  Tries to find the
# nearest reference in the manual.
#
# Arguments:
# string -              Text to output in the state(paragraph).

proc insertRef {string} {
    global NAME_file curPkg curSect topics curID
    set path {}
    set string [string trim $string]
    set ref {}
    if {[info exists topics($curPkg,$curSect,$string)]} {
        set ref $topics($curPkg,$curSect,$string)
    } else {
        set sites [array names topics "$curPkg,*,$string"]
        set count [llength $sites]
        if {$count > 0} {
            set ref $topics([lindex $sites 0])
        } else {
            set sites [array names topics "*,*,$string"]
            set count [llength $sites]
            if {$count > 0} {
                set ref $topics([lindex $sites 0])
            }
        }
    }

    if {($ref != {}) && ($ref != $curID)} {
        set string [link $string $ref]
    }
    return $string
}



# macro --
#
# This procedure is invoked to process macro invocations that start
# with "." (instead of ').
#
# Arguments:
# name -                The name of the macro (without the ".").
# args -                Any additional arguments to the macro.

proc macro {name args} {
    global state file
    switch $name {
        AP {
            if {[llength $args] != 3 && [llength $args] != 2} {
                puts stderr "Bad .AP macro: .$name [join $args " "]"
            }
            newPara 3.75i -3.75i
            setTabs {1.25i 2.5i 3.75i}
            font B
            text [lindex $args 0]
            tab
            font I
            text [lindex $args 1]
            tab
            font R
            if {[llength $args] == 3} {
                text "([lindex $args 2])"
            }
            tab
        }
        AS {
            # next page and previous page
        }
        br {
            lineBreak   
        }
        BS {}
        BE {}
        CE {
            puts -nonewline $::file "\\f0\\fs20 "
            set state(noFill) 0
            set state(breakPending) 0
            newPara ""
            set state(leftIndent) [expr {$state(leftIndent) - $state(offset)}]
            set state(sb) 80
        }
        CS {
            # code section
            set state(noFill) 1
            newPara ""
            set state(leftIndent) [expr {$state(leftIndent) + $state(offset)}]
            set state(sb) 80
            puts -nonewline $::file "\\f1\\fs18 "
        }
        DE {
            set state(noFill) 0
            decrNestingLevel
            newPara 0i
        }
        DS {
            set state(noFill) 1
            incrNestingLevel
            newPara 0i
        }
        fi {
            set state(noFill) 0
        }
        IP {
            IPmacro $args
        }
        LP {
            newPara 0i
            set state(sb) 80
        }
        ne {
        }
        nf {
            set state(noFill) 1
        }
        OP {
            if {[llength $args] != 3} {
                puts stderr "Bad .OP macro: .$name [join $args " "]"
            }
            set state(nestingLevel) 0
            newPara 0i
            set state(sb) 120
            setTabs 4c
            text "Command-Line Name:"
            tab
            font B
            set x [lindex $args 0]
            regsub -all {\\-} $x - x
            text $x
            lineBreak
            font R
            text "Database Name:"
            tab
            font B
            text [lindex $args 1]
            lineBreak
            font R
            text "Database Class:"
            tab
            font B
            text [lindex $args 2]
            font R
            set state(inTP) 0
            newPara 0.5i
            set state(sb) 80
        }
        PP {
            newPara 0i
            set state(sb) 120
        }
        RE {
            decrNestingLevel
        }
        RS {
            incrNestingLevel
        }
        SE {
            font R
            set state(noFill) 0
            set state(nestingLevel) 0
            newPara 0i
            text "See the "
            font B
            set temp $state(textState)
            set state(textState) REF
            text options
            set state(textState) $temp
            font R
            text " manual entry for detailed descriptions of the above options."
        }
        SH {
            SHmacro $args
        }
        SS {
            SHmacro $args subsection
        }
        SO {
            SHmacro "STANDARD OPTIONS"
            set state(nestingLevel) 0
            newPara 0i
            setTabs {4c 8c 12c}
            font B
            set state(noFill) 1
        }
        so {
            if {$args != "man.macros"} {
                puts stderr "Unknown macro: .$name [join $args " "]"
            }
        }
        sp {                                    ;# needs work
            if {$args == ""} {
                set count 1
            } else {
                set count [lindex $args 0]
            }
            while {$count > 0} {
                lineBreak
                incr count -1
            }
        }
        ta {
            setTabs $args
        }
        TH {
            THmacro $args
        }
        TP {
            TPmacro $args
        }
        UL {                                    ;# underline
            puts -nonewline $file "{\\ul "
            text [lindex $args 0]
            puts -nonewline $file "}"
            if {[llength $args] == 2} {
                text [lindex $args 1]
            }
        }
        VE {}
        VS {}
        QW {
            formattedText "``[lindex $args 0]''[lindex $args 1] "
        }
        MT {
            text "``'' "
        }
        PQ {
            formattedText \
                "(``[lindex $args 0]''[lindex $args 1])[lindex $args 2] "
        }
        QR {
            formattedText "``[lindex $args 0]"
            dash
            formattedText "[lindex $args 1]''[lindex $args 2] "
        }
        default {
            puts stderr "Unknown macro: .$name [join $args " "]"
        }
    }
}


# link --
#
# This procedure returns the string for  a hot link to a different
# context location.
#
# Arguments:
# label -               String to display in hot-spot.
# id -                  Context string to jump to.

proc link {label id} {
    return "{\\uldb $label}{\\v $id}"
}


# font --
#
# This procedure is invoked to handle font changes in the text
# being output.
#
# Arguments:
# type -                Type of font: R, I, B, or S.

proc font {type} {
    global state
    switch $type {
        P -
        R {
            endFont
            if {$state(textState) == "REF"} {
                set state(textState) INSERT
            }
        }
        C -
        B {
            beginFont Code
            if {$state(textState) == "INSERT"} {
                set state(textState) REF
            }
        }
        I {
            beginFont Emphasis
        }
        S {
        }
        default {
            puts stderr "Unknown font: $type"
        }
    }
}



# formattedText --
#
# Insert a text string that may also have \fB-style font changes
# and a few other backslash sequences in it.
#
# Arguments:
# text -                Text to insert.

proc formattedText {text} {
    global chars

    while {$text != ""} {
        set index [string first \\ $text]
        if {$index < 0} {
            text $text
            return
        }
        text [string range $text 0 [expr {$index-1}]]
        set c [string index $text [expr {$index+1}]]
        switch -- $c {
            f {
                font [string index $text [expr {$index+2}]]
                set text [string range $text [expr {$index+3}] end]
            }
            e {
                text "\\"
                set text [string range $text [expr {$index+2}] end]
            }
            - {
                dash
                set text [string range $text [expr {$index+2}] end]
            }
            & - | {
                set text [string range $text [expr {$index+2}] end]
            }
            ( {
                char [string range $text $index [expr {$index+3}]]
                set text [string range $text [expr {$index+4}] end]
            }
            default {
                puts stderr "Unknown sequence: \\$c"
                set text [string range $text [expr {$index+2}] end]
            }
        }
    }
}


# dash --
#
# This procedure is invoked to handle dash characters ("\-" in
# troff).  It outputs a special dash character.
#
# Arguments:
# None.

proc dash {} {
    global state
    if {[string equal $state(textState) "NAME"]} {
        set state(textState) 0
    }
    text "-"
}


# tab --
#
# This procedure is invoked to handle tabs in the troff input.
# Right now it does nothing.
#
# Arguments:
# None.

proc tab {} {
    global file

    textSetup
    puts -nonewline $file "\\tab "
}


# setTabs --
#
# This procedure handles the ".ta" macro, which sets tab stops.
#
# Arguments:
# tabList -     List of tab stops in *roff format

proc setTabs {tabList} {
    global file state

    set state(tabs) {}
    foreach arg $tabList {
        if {[string match +* $arg]} {
            set relativeTo [lindex $state(tabs) end]
            set arg [string range $arg 1 end]
        } else {
            # Local left margin
            set relativeTo [expr {$state(leftMargin) \
                    + ($state(offset) * $state(nestingLevel))}]
        }
        if {[regexp {^\w'(.*)'u$} $arg -> submatch]} {
            # Magic factor!
            set distance [expr {[string length $submatch] * 86.4}]
        } else {
            set distance [getTwips $arg]
        }
        lappend state(tabs) [expr {round($distance + $relativeTo)}]
    }
}


# lineBreak --
#
# Generates a line break in the HTML output.
#
# Arguments:
# None.

proc lineBreak {} {
    global state
    textSetup
    set state(breakPending) 1
}



# newline --
#
# This procedure is invoked to handle newlines in the troff input.
# It outputs either a space character or a newline character, depending
# on fill mode.
#
# Arguments:
# None.

proc newline {} {
    global state

    if {$state(inTP)} {
        set state(inTP) 0
        lineBreak
    } elseif {$state(noFill)} {
        lineBreak
    } else {
        text " "
    }
}


# pageBreak --
#
# This procedure is invoked to generate a page break.
#
# Arguments:
# None.

proc pageBreak {} {
    global file curVer
    if {[string equal $curVer ""]} {
        puts $file {\page}
    } else {
        puts $file {\par}
        puts $file {\pard\sb400\qc}
        puts $file "Last change: $curVer\\page"
    }
}


# char --
#
# This procedure is called to handle a special character.
#
# Arguments:
# name -                Special character named in troff \x or \(xx construct.

proc char {name} {
    global file state

    switch -exact $name {
        {\o} {
            set state(intl) 1
        }
        {\ } {
            textSetup
            puts -nonewline $file " "
        }
        {\0} {
            textSetup
            puts -nonewline $file " \\emspace "
        }
        {\\} - {\e} {
            textSetup
            puts -nonewline $file "\\\\"
        }
        {\(+-} {
            textSetup
            puts -nonewline $file "\\'b1 "
        }
        {\%} - {\|} {
        }
        {\(->} {
            textSetup
            puts -nonewline $file "->"
        }
        {\(bu} {
            textSetup
            puts -nonewline $file "\\bullet "
        }
        {\(co} {
            textSetup
            puts -nonewline $file "\\'a9 "
        }
        {\(mu} {
            textSetup
            puts -nonewline $file "\\'d7 "
        }
        {\(em} {
            textSetup
            puts -nonewline $file "-"
        }
        {\(fm} {
            textSetup
            puts -nonewline $file "\\'27 "
        }
        default {
            puts stderr "Unknown character: $name"
        }
    }
}


# macro2 --
#
# This procedure handles macros that are invoked with a leading "'"
# character instead of space.  Right now it just generates an
# error diagnostic.
#
# Arguments:
# name -                The name of the macro (without the ".").
# args -                Any additional arguments to the macro.

proc macro2 {name args} {
    puts stderr "Unknown macro: '$name [join $args " "]"
}



# SHmacro --
#
# Subsection head; handles the .SH and .SS macros.
#
# Arguments:
# name -                Section name.

proc SHmacro {argList {style section}} {
    global file state

    set args [join $argList " "]
    if {[llength $argList] < 1} {
        puts stderr "Bad .SH macro: .SH $args"
    }

    # control what the text proc does with text
    
    switch $args {
        NAME {set state(textState) NAME}
        DESCRIPTION {set state(textState) INSERT}
        INTRODUCTION {set state(textState) INSERT}
        "WIDGET-SPECIFIC OPTIONS" {set state(textState) INSERT}
        "SEE ALSO" {set state(textState) SEE}
        KEYWORDS {set state(textState) KEY; return}
    }

    if {$state(breakPending) != -1} {
        set state(breakPending) 1
    } else {
        set state(breakPending) 0
    }
    set state(noFill) 0
    if {[string compare "subsection" $style] == 0} {
        nextPara .25i
    } else {
        nextPara 0i
    }
    font B
    text $args
    font R
    nextPara .5i
}

# IPmacro --
#
# This procedure is invoked to handle ".IP" macros, which may take any
# of the following forms:
#
# .IP [1]               Translate to a "1Step" state(paragraph).
# .IP [x] (x > 1)       Translate to a "Step" state(paragraph).
# .IP                   Translate to a "Bullet" state(paragraph).
# .IP text count        Translate to a FirstBody state(paragraph) with special
#                       indent and tab stop based on "count", and tab after
#                       "text".
#
# Arguments:
# argList -             List of arguments to the .IP macro.
#
# HTML limitations: 'count' in '.IP text count' is ignored.

proc IPmacro {argList} {
    global file state

    set length [llength $argList]
    foreach {text indent} $argList break
    if {$length > 2} {
        puts stderr "Bad .IP macro: .IP [join $argList " "]"
    }

    if {$length == 0} {
        set text {\(bu}
        set indent 5
    } elseif {$length == 1} {
        set indent 5
    }
    if {$text == {\(bu}} {
        set text "\u00b7"
    }

    set tab [expr $indent * 0.1]i
    newPara $tab -$tab
    set state(sb) 80
    setTabs $tab
    formattedText $text
    tab
}

# TPmacro --
#
# This procedure is invoked to handle ".TP" macros, which may take any
# of the following forms:
#
# .TP x         Translate to an state(indent)ed state(paragraph) with the
#                       specified state(indent) (in 100 twip units).
# .TP           Translate to an state(indent)ed state(paragraph) with
#                       default state(indent).
#
# Arguments:
# argList -             List of arguments to the .IP macro.
#
# HTML limitations: 'x' in '.TP x' is ignored.

proc TPmacro {argList} {
    global state
    set length [llength $argList]
    if {$length == 0} {
        set val 0.5i
    } else {
        set val [expr {([lindex $argList 0] * 100.0)/1440}]i
    }
    newPara $val -$val
    setTabs $val
    set state(inTP) 1
    set state(sb) 120
}


# THmacro --
#
# This procedure handles the .TH macro.  It generates the non-scrolling
# header section for a given man page, and enters information into the
# table of contents.  The .TH macro has the following form:
#
# .TH name section date footer header
#
# Arguments:
# argList -             List of arguments to the .TH macro.

proc THmacro {argList} {
    global file curPkg curSect curID id_keywords state curVer bitmap

    if {[llength $argList] != 5} {
        set args [join $argList " "]
        puts stderr "Bad .TH macro: .TH $args"
    }
    incr curID
    set name    [lindex $argList 0]             ;# Tcl_UpVar
    set page    [lindex $argList 1]             ;# 3
    set curVer  [lindex $argList 2]             ;# 7.4
    set curPkg  [lindex $argList 3]             ;# Tcl
    set curSect [lindex $argList 4]             ;# {Tcl Library Procedures}
    
    regsub -all {\\ } $curSect { } curSect      ;# Clean up for [incr\ Tcl]

    puts $file "#{\\footnote $curID}"           ;# Context string
    puts $file "\${\\footnote $name}"           ;# Topic title
    set browse "${curSect}${name}"
    regsub -all {[ _-]} $browse {} browse
    puts $file "+{\\footnote $browse}"          ;# Browse sequence

    # Suppress duplicates
    foreach i $id_keywords($curID) {
        set keys($i) 1
    }
    foreach i [array names keys] {
        set i [string trim $i]
        if {[string length $i] > 0} {
            puts $file "K{\\footnote $i}"       ;# Keyword strings
        }
    }
    unset keys
    puts $file "\\pard\\tx3000\\sb100\\sa100\\fs24\\keepn"
    font B
    text $name
    tab
    text $curSect
    font R
    if {[info exists bitmap]} {
        # a right justified bitmap
        puts $file "\\\{bmrt $bitmap\\\}"
    }
    puts $file "\\fs20"
    set state(breakPending) -1
}

# nextPara --
#
# Set the indents for a new paragraph, and start a paragraph break
#
# Arguments:
# leftIndent -          The new left margin for body lines.
# firstIndent -         The offset from the left margin for the first line.

proc nextPara {leftIndent {firstIndent 0i}} {
    global state
    set state(leftIndent) [getTwips $leftIndent]
    set state(firstIndent) [getTwips $firstIndent]
    set state(paragraphPending) 1
}


# newPara --
#
# This procedure sets the left and hanging state(indent)s for a line.
# State(Indent)s are specified in units of inches or centimeters, and are
# relative to the current nesting level and left margin.
#
# Arguments:
# leftState(Indent) -           The new left margin for lines after the first.
# firstState(Indent) -          The new left margin for the first line of a state(paragraph).

proc newPara {leftIndent {firstIndent 0i}} {
    global state file
    if $state(paragraph) {
        puts -nonewline $file "\\line\n"
    }
    if {$leftIndent != ""} {
        set state(leftIndent) [expr {$state(leftMargin) \
                + ($state(offset) * $state(nestingLevel)) \
                + [getTwips $leftIndent]}]
    }
    set state(firstIndent) [getTwips $firstIndent]
    set state(paragraphPending) 1
}


# getTwips --
#
# This procedure converts a distance in inches or centimeters into
# twips (1/1440 of an inch).
#
# Arguments:
# arg -                 A number followed by "i" or "c"

proc getTwips {arg} {
    if {[scan $arg "%f%s" distance units] != 2} {
        puts stderr "bad distance \"$arg\""
        return 0
    }
    switch -- $units {
        c       {
            set distance [expr {$distance * 567}]
        }
        i       {
            set distance [expr {$distance * 1440}]
        }
        default {
            puts stderr "bad units in distance \"$arg\""
            continue
        }
    }
    return $distance
}

# incrNestingLevel --
#
# This procedure does the work of the .RS macro, which increments
# the number of state(indent)ations that affect things like .PP.
#
# Arguments:
# None.

proc incrNestingLevel {} {
    global state

    incr state(nestingLevel)
    set oldp $state(paragraph)
    set state(paragraph) 0
    newPara 0i
    set state(paragraph) $oldp
}

# decrNestingLevel --
#
# This procedure does the work of the .RE macro, which decrements
# the number of indentations that affect things like .PP.
#
# Arguments:
# None.

proc decrNestingLevel {} {
    global state
    
    if {$state(nestingLevel) == 0} {
        puts stderr "Nesting level decremented below 0"
    } else {
        incr state(nestingLevel) -1
    }
}