Subversion Repositories or1k

#!/bin/sh
# \
    exec itkwish "$0" ${1+"$@"}
#
# mkitclman "4 Dec 1995"
# mkitclman - generate a man page from an itcl class
#
# SYNOPSIS
#   mkitclman classfile
#
# DESCRIPTION
#   Reads an [incr Tcl] or [incr Tk] class file as input, and outputs nroff.
#   mkitclman generates a standard format used for [incr Widget] classes. It
#   locates the class name, inheritance to one level, widget specific options,
#   and widget specific methods. Areas that the script cannot handle it 
#   places and uppercased name delimited by leading and trailing '_' characters.
#
#   [incr Tcl/Tk] 2.0 is the supported class format. 
#
# CAVEATS
#   mkitlcman does not work with normal Tk or Tcl script files. 
#   It expects only one class per file. In addition, it does not work on
#   namespace files.

proc init { } {
        global _className
        global _inheritClass
    global _publicMethod
    global _publicVariable
    global _protectedMethod
    global _protectedVariable
    global _privateMethod
    global _privateVariable
        global _options

        set _className {}
        set _inheritClass {}

}
proc namespace { args } {
        global _className

        set _className [lindex $args 0]
        set classBody [lindex $args 1]

        eval $classBody
}
proc class { args } {
        global _className

        set _className [lindex $args 0]
        set classBody [lindex $args 1]

        eval $classBody
}
proc itk_option { action switch args } {
        global _options

        if { $action == "define" } {
                set _options($switch) $args
        }
}
proc inherit { inheritClass } {
        global _inheritClass
        set _inheritClass $inheritClass
}

# default is public method
proc method { name args } {
        global _publicMethod

        set _publicMethod($name) $args
}

# pick up arrays later...
proc common { name args } {
        global _commonVariable

        # set to defaults
        set _commonVariable($name) $args
}

proc public { type args } {
        global _publicMethod
        global _publicVariable

        switch $type {
                method {
                        set _publicMethod([lindex $args 0]) [lindex $args 1]
                }
                variable {
                        # _publicVariable(varName) = defaultValue
                        set _publicVariable([lindex $args 0]) [lindex $args 1]
                }
        }
}

proc protected { type args } {
        global _protectedMethod
        global _protectedVariable

        switch $type {
                method {
                        # _protectedMethod(methodName) = argList
                        set _protectedMethod([lindex $args 0]) [lrange $args 1 end]
                }
                variable {
                        # _protectedVariable(varName) = defaultValue
                        set _protectedVariable([lindex $args 0]) [lindex $args 1]
                }
        }
}

proc private { type args } {
        global _privateMethod
        global _privateVariable

        switch $type {
                method {
                        # _privateMethod(methodName) = argList
                        set _privateMethod([lindex $args 0]) [lrange $args 1 end]
                }
                variable {
                        # _privateVariable(varName) = defaultValue
                        set _privateVariable([lindex $args 0]) [lindex $args 1]
                }
        }
}

proc body { args } {
}

proc configbody { args } {
}

proc destructor { args } {
}
proc constructor { args } {
}

proc gen { } {
        global _className
    global _classBody
        global _inheritClass
    global _publicMethod
    global _publicVariable
    global _protectedMethod
    global _protectedVariable
    global _privateMethod
    global _privateVariable
    global _methodSection
    global _optionSection
        global _manpage
        global _optionManFmt
        global _methodManFmt
        global _method
        global _options
        global _optionSwitch
        global _optionName
        global _optionClass

        if { $_inheritClass != {} } {
                set _inheritClass "$_inheritClass <-"
        }
        set _optionManFmt {}
        set _methodManFmt {}
        set _methodArgs {}
        foreach pbv [lsort [array names _publicVariable]]  {
                set _optionSwitch "-$pbv"
                set _optionName $pbv
                set _optionClass "[string toupper [string index $pbv 0]][string range $pbv 1 end]"
                lappend _optionManFmt [subst -nobackslash -nocommand $_optionSection]
        }

        foreach opt [lsort [array names _options]] {
                set _optionSwitch $opt
                set _optionName [lindex $_options($opt) 0]
                set _optionClass [lindex $_options($opt) 1]
                lappend _optionManFmt [subst -nobackslash -nocommand $_optionSection]
        }
        foreach pbm [lsort [array names _publicMethod]] {
                set _method $pbm
                eval set _methodArgs [list $_publicMethod($pbm)]
                lappend _methodManFmt [subst -nobackslash -nocommand $_methodSection]
        }
        foreach ptm [lsort [array names _protectedMethod]] {
        }
        foreach ptv [lsort [array names _protectedVariable]] {
        }
        foreach pvm [lsort [array names _privateMethod]] {
        }
        foreach pvv [lsort [array names _privateVariable]] {
        }

        set _methodManFmt [join $_methodManFmt " "]
        set _optionManFmt [join $_optionManFmt " "]

        set _manpage [subst -nobackslash -nocommand $_manpage]

        puts $_manpage
}

set _manpage {
'\"
'\" Copyright (c) _AUTHOR_
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" @(#) $_className.n
'/"
.so man.macros
.HS $_className iwid
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
'\"
'\"
.SH NAME
$_className \- _NAME_DESCRIPTION_
.SH SYNOPSIS
\fB$_className\fI \fIpathName\fR ?\fIoptions\fR?
.SH "INHERITANCE"
$_inheritClass $_className
.SH "STANDARD OPTIONS"
.LP
.nf
.ta 4c 8c 12c
_STANDARD_OPTIONS_
.fi
.LP
See the "options" manual entry for details on the standard options.
.SH "ASSOCIATED OPTIONS"
.LP
.nf
.ta 4c 8c 12c
_ASSOCIATED_OPTIONS_
.fi
.LP
See the "_ASSOCIATED_WIDGET_" widget manual entry for details on the above
associated options.
.SH "INHERITED OPTIONS"
.LP
.nf
.ta 4c 8c 12c
_INHERITED_OPTIONS_
.fi
.LP
See the "_INHERITED_WIDGET_" class manual entry for details on the inherited options.
.SH "WIDGET-SPECIFIC OPTIONS"
.LP
$_optionManFmt
.BE
.SH DESCRIPTION
.PP
_DESCRIPTION_
.SH "METHODS"
.PP
The \fB$_className\fR command creates a new Tcl command whose
name is \fIpathName\fR.  This
command may be used to invoke various
operations on the widget.  It has the following general form:
.DS C
\fIpathName option \fR?\fIarg arg ...\fR?
.DE
\fIOption\fR and the \fIarg\fRs
determine the exact behavior of the command.  The following
commands are possible for $_className widgets:
.SH "ASSOCIATED METHODS"
.LP
.nf
.ta 4c 8c 12c
_ASSOCIATED_METHODS_
.fi
.LP
See the "_ASSOCIATED_WIDGET_" manual entry for details on the standard methods.
.SH "WIDGET-SPECIFIC METHODS"
$_methodManFmt
.SH "COMPONENTS"
.LP
.nf
Name:   \fB_COMPONENT_NAME_\fR
Class:  \fB_COMPONENT_CLASS_\fR
.fi
.IP
_COMPONENT_DESCRIPTION_
See the "_COMPONENT_TYPE_" widget manual entry for details on the _COMPONENT_NAME_ component item.
.fi
.SH EXAMPLE
.DS
_EXAMPLE_CODE_
.DE
.SH AUTHOR
_AUTHOR_
.SH KEYWORDS
_KEYWORDS_
}

set _optionSection {
.nf
Name:   \fB$_optionName\fR
Class:  \fB$_optionClass\fR
Command-Line Switch:    \fB$_optionSwitch\fR
.fi
.IP
_OPTION_DESCRIPTION_
.LP
}

set _methodSection {
.TP
\fIpathName\fR \fB$_method\fR \fI$_methodArgs\fR
_METHOD_DESCRIPTION_
}

# Add these two lines up into the man page above to enable

init
source [lindex $argv 0]
gen
exit