[Xotcl] Some fixes to xodoc
Kristoffer Lawson
setok at fishpool.com
Thu Dec 21 02:11:44 CET 2000
Attached to this post I have a slightly fixed version of xodoc. I did the
following corrections/additions:
- Added space between the different "sections" of class
descriptions. Ie. as in the following case:
@ Class Foo {
description {blah}
errors {foo}
}
It would just stick 'description' and 'errors' on to the same line.
- Added functionality to handle optional procedure arguments. Ie. as in
thee following case:
@ Foo instproc {arg1 {arg2 ""}} {}
Now it marks arg2 as optional with the standard Tcl syntax, and also
automatically specifies the default value along with the description.
- Added some special handling for the section 'errorCodes' in a
class. These error codes are the things you can give with the
[error] command to give a code to the error, so catching is
easier. Ie. the following:
@ Class Foo {
description {blah}
errorCodes {
MyAppError {
Used for sending errors my application specifically
creates.
}
}
}
What I didn't do:
I was going to add an extension facility so that applications could
specify their own handler-objects for certain special sections. Like in
Class Foo above I might have a section {Attribute Aliases} in addition to
errorCodes (as I do). I would like to specify a AttrAliasDocHandle object,
for example, which would have the method "toHtml" (if outputting HTML)
that gets called when the section {Attribute Aliases} is encountered, with
the data passed to it as an argument. This would then return a nice HTML
table documenting my aliases.
The syntax to create an extension might be something like this:
@ @DocExtension Class {Attribute Aliases} AttrAliasDocHandle
I would have done this myself but it's already late (3am) and I really
desperately need to continue my real work. If anyone feels like
implementing that, then feel free... Otherwise I'll just have to get back
to it at some later time :-(
- ---------- = = ---------//--+
| / Kristoffer Lawson | www.fishpool.fi|.com
+-> | setok at fishpool.com | - - --+------
|-- Fishpool Creations Ltd - / |
+-------- = - - - = --------- /~setok/
-------------- next part --------------
# $Id: xodoc.xotcl,v 1.7 2000/11/29 22:20:15 neumann Exp $
package provide xoDoc 0.82
#package require trace
@ @File {
description {
XOTcl documentation tool. Overloads the command @, which is used
as a documentation token.
}
}
Class DocToken -parameter {
{name ""}
{docProperties ""}
}
DocToken proc sortTokenList l {
foreach t $l {
set names([$t set name]) $t
}
set sortedName [lsort [array names names]]
set sortedList ""
foreach n $sortedName {
lappend sortedList [set names($n)]
}
return $sortedList
}
DocToken instproc evaluateDoc doc {
foreach {p v} $doc {
[self] set $p $v
[self] lappend docProperties $p
}
}
DocToken instproc capitalize string {
if {$::tcl_version >= 8.3} {
string toupper $string 0 0
} else {
return "[string toupper [string range $string 0 0]][string range $string 1 end]"
}
}
@ DocToken instproc getDocPropertiesHTML {} {
description {
Returns list of properties as HTML.
}
}
DocToken instproc getDocPropertiesHTML {} {
set c ""
foreach p [[self] set docProperties] {
if {[[self] exists $p]} {
append c "<p><em>" [[self] capitalize $p] ":</em>"
if {[string equal $p "errorCodes"]} {
# Build table with list of error codes.
append c "<blockquote><table>"
foreach {code desc} [[self] set $p] {
set code [string map [list < <\; > >\;] $code]
set desc [string map [list < <\; > >\;] $desc]
append c "<tr><td valign=\"top\"><b>$code</b><td>$desc"
}
append c "</table></blockquote>"
} else {
append c [[self] reflowHTML " " [[self] set $p]] \n\n
}
}
}
return $c
}
DocToken instproc reflowHTML {left paragraph} {
#set result ""
#foreach line [split $paragraph \n] {
# if {![regexp {^ *$} $line]} {
# append result "$left$line<br>\n"
# }
#}
#return $result
return $paragraph
}
Class DocFile -superclass DocToken
DocFile instproc printHTML {} {
set c "<br><b> Filename: </b> <A href='[[self] set name]'>[[self] set name]</A>
<br><br>\n"
append c "[[self] getDocPropertiesHTML] <br>\n"
return $c
}
Class DocPackage -superclass DocToken -parameter {
{version ""}
{type ""}
}
Class DocObj -superclass DocToken -parameter {
{procList ""}
cl
}
DocObj instproc getProcsHTML {} {
set c ""
set pl [DocToken sortTokenList [[self] procList]]
if {[[self] istype DocCl]} {
set pl [concat [DocToken sortTokenList [[self] instprocList]] $pl]
}
foreach p $pl {
set pn [$p set name]
set label($pn) "<a href=\"#[[self] set name]-$pn\">$pn</a>"
}
foreach l [lsort [array names label]] {
if {$c != ""} {append c ", "}
append c $label($l)
}
if {$c != ""} {append c "."}
return $c
}
DocObj instproc printHTML {} {
set c "<a name=\"[[self] set name]\"></a><h2> Object: <em> [[self] set name] </em> </h2>\n"
if {[[self] exists cl]} {
append c "<b>Class</b>: [[self] set cl] <br>\n"
}
if {[[self] exists heritage]} {
append c "<b>Heritage</b>: [[self] set heritage] <br>\n"
}
set head "<b> Procs </b> "
if {[[self] istype DocCl]} {
set head "<b> Procs/Instprocs: </b> "
}
append c "$head \n [[self] getProcsHTML]" \
"<br><p>\n" \
[[self] getDocPropertiesHTML]
return $c
}
Class DocCl -superclass DocObj -parameter {
{instprocList ""}
}
DocCl instproc init args {
[self] set obj [[self class] autoname clobj]
next
}
DocCl instproc printHTML {} {
regsub "<h2> Object:" [next] "<h2> Class:" r
return $r
}
Class DocMetaCl
DocMetaCl instproc printHTML {} {
regsub "<h2> Class:" [next] "<h2> Meta-Class:" r
return $r
}
Class DocMethod -superclass DocToken -parameter {
arguments
returnValue
obj
}
# Prints out method information as HTML.
DocMethod instproc printHTML {} {
#[self] showVars
set argText "\n"
set a "<td><em>Arguments:</em> </td>"
set anchor "[[self] set obj]-[[self] set name]"
set c "<a name=\"$anchor\"></a>\n<li><b>[[self] set name] "
if {[[self] exists arguments]} {
foreach {arg argD} [[self] set arguments] {
if {[llength $arg] > 1} {
# A default value was given to the argument.
append c " <em>?[lindex $arg 0]?</em>"
append argText "<tr valign=\"top\">$a<td>"
append argText "<b>?[lindex $arg 0]?</b>:" \
[[self] reflowHTML " " \
"$argD Default: \"[lindex $arg 1]\"."] \
"</td></tr>\n"
} else {
append c " <em>$arg</em>"
append argText "<tr valign=\"top\">$a<td><b>$arg</b>: " \
"[[self] reflowHTML " " $argD]</td></tr>\n"
}
set a "<td></td>"
}
}
append c " </b><br>\n<table>\n" \
$argText [[self] getDocPropertiesHTML] \n \
</table> \n
return $c
}
Class DocProc -superclass DocMethod
Class DocInstproc -superclass DocMethod
@ Class XODoc { description "Handler class for building a documentation database" }
Class XODoc -parameter {
{objList ""}
{packageList ""}
{knownMetaclasses "Class"}
{ns ""}
fileToken
}
XODoc instproc init args {
next
}
@ XODoc proc documentFileAsHTML {file "filename of the xotcl file to be documented"
docdir "directory to which the html file is written"} {
description "Uses the xoDoc package to produce an HTML documentation of
a specified file ***.xotcl. The file is written to ***.html
in docdir"
return "file basename without suffix"
}
XODoc proc documentFileAsHTML {file docdir} {
set docdb [XODoc [XODoc autoname docdb]]
::@ set xoDocObj $docdb
$docdb readFile $file
set fb $file
regexp {([^/]*)\.[^.]*$} $fb _ fb
$docdb writeFile ${docdir}/$fb.html $fb [$docdb printHTML]
$docdb destroy
return $fb
}
XODoc instproc handleMethod {obj type name {argList ""} {doc ""}} {
#puts stderr "+++Method $type $name $argList $doc"
set procClass DocProc; set objCl DocObj
if {$type == "instproc"} {set procCl DocInstproc; set objCl DocCl}
set t [$procClass create [[self] autoname t]]
set n [$t set name [string trimleft $name :]]
$t set obj $obj
set objFound 0
foreach o [[self] set objList] {
if {[$o set name] == $obj} {
set objFound 1
if {$type == "instproc" && ![$o istype DocCl]} {
$o class DocCl
}
break
}
}
if {$objFound == 0} {
set o [$objCl create [[self] autoname t]]
$o set name $obj
[self] lappend objList $o
}
$o lappend ${type}List $t
$t set arguments $argList
$t evaluateDoc $doc
}
XODoc instproc handleObj {class name args} {
[self] instvar knownMetaclasses objList extensions
set objCl DocObj
if {[lsearch $class $knownMetaclasses] != -1} {
set objCl DocCl
}
# if an instproc/proc has created an entry for this obj/class
# -> use it and overwrite it with new info
if {[set idx [lsearch $name $objList]] != -1} {
set t [lindex $objList $idx]
$t class $objCl
} else {
set t [$objCl create [[self] autoname t]]
[self] lappend objList $t
}
$t set name $name
set la [llength $args]
# evaluate -superclass argument
if {($la == 3 || $la == 2) && [lindex $args 0] == "-superclass"} {
set heritage [$t set heritage [lindex $args 1]]
foreach h $heritage {
if {[lsearch $h $knownMetaclasses] != -1} {
# A new metaclass was defined
lappend knownMetaclasses $name
$t class DocMetaCl
}
}
}
# evaluate documentation
set doc ""
if {$la == 1} {
set doc [lindex $args 0]
} elseif {$la == 3} {
set doc [lindex $args 2]
}
$t evaluateDoc $doc
$t set cl $class
#puts stderr "+++Obj $name $args"
}
XODoc instproc handleFile doc {
if {[[self] exists fileToken]} {
[[self] set fileToken] evaluateDoc $doc
}
}
XODoc instproc handlePackage args {
#puts "$args"
if {[llength $args] > 2} {
set type [lindex $args 1]
if {$type == "provide" || $type == "require"} {
set t [DocPackage create [[self] autoname t]]
[self] lappend packageList $t
$t set name [lindex $args 2]
$t set type $type
if {[llength $args] > 3} {
$t set version [lindex $args 3]
}
}
}
}
XODoc instproc printHTML {} {
[self] instvar extensions
set c "<h2> Package/File Information </h2>"
[self] instvar packageList
if {[llength $packageList] > 0} {
foreach t $packageList {
if {[$t type] == "provide"} {
append c "<b> Package provided: </b> [$t name] [$t version]<br>\n"
} elseif {[$t type] == "require"} {
append c "<b> Package required: </b> [$t name] [$t version]<br>\n"
}
}
} else {
append c "<b> No package provided/required </b><br>\n"
}
if {[info exists extensions]} {
# Add list of extensions.
foreach extension $extensions {
append c "<hr>"
append c "<h2>Document extension: <em>[$extension name]</em></h2>"
append c "<em>Description:</em> [$extension description]"
}
}
set objList [DocToken sortTokenList [[self] objList]]
if {[llength $objList]>0} {
append c "<br><b>Defined Objects/Classes: </b> \n<ul>"
foreach obj $objList {
set on [$obj set name]
append c " <li><a href=\"#$on\"><em>$on</em></a>: \
[$obj getProcsHTML]<br>\n"
}
append c "</ul>\n"
}
if {[[self] exists fileToken]} {
append c "[[[self] set fileToken] printHTML]<br>"
} else {
append c "<b> No file information. </b><br>\n"
}
foreach t $objList {
append c "<p><hr><p>\n" [$t printHTML]
set pl [$t set procList]
if {[$t istype DocCl]} {
set ipl [$t set instprocList]
if {[llength $ipl] > 0} {
append c "<h3>Instprocs</h3>\n<ul>\n"
foreach s $ipl {
append c [$s printHTML]
}
append c "</ul>\n"
}
}
if {[llength $pl] > 0} {
append c "<h3>Procs</h3>\n<ul>\n"
foreach s $pl {
append c [$s printHTML]
}
append c "</ul>\n"
}
#append c "<hr>\n"
}
return $c
}
XODoc instproc getCommand {content} {
upvar $content c
[self] instvar cmd
if {[set line [string first "\n" $c]] != -1} {
append cmd [string range $c 0 $line] \n
set c [string range $c [expr $line + 1] end]
if {[info complete $cmd]} {
set r $cmd; set cmd ""
return $r
}
} else {
return ""
}
[self] getCommand c
}
XODoc instproc evaluateCommands {c} {
while 1 {
set command [[self] getCommand c]
if {$command == ""} {
break
}
#puts stderr "$command==========================="
if {[regexp "^ *:*@ " $command]} {
#puts stderr "$command==========================="
eval $command
} elseif {[regexp "^ *package " $command]} {
#puts stderr "$command==========================="
eval [self] handlePackage $command
} elseif {[regexp "^ *namespace *eval *(\[^\{\]*) *\{(.*)\}\[^\}\]*$" $command _ namespace nsc]} {
#puts stderr "$command==========================="
[self] evaluateCommands $nsc
}
}
}
XODoc instproc readFile name {
[self] set cmd ""
set t [DocFile create [[self] autoname t]]
$t set name $name
[self] set fileToken $t
set f [open $name r]
set c [read $f]
close $f
[self] evaluateCommands $c
}
XODoc instproc replaceFormatTags {fc} {
regsub -all <@ $fc < fc
regsub -all </@ $fc </ fc
return $fc
}
XODoc instproc writeFile {filename name filecontent} {
#set filename [[self] set DOCDIR]/$name.html
set filecontent [[self] replaceFormatTags $filecontent]
set content {
<html>
<head>
<title>XOTcl - Documentation -- $name</title>
</head>
<body bgcolor=FFFFFF>
<h1><IMG ALIGN=MIDDLE SRC = "./logo-100.jpg">$name</h1>
<hr>
<p>
$filecontent
<p><hr>
<a HREF="./index.html">Back to index page.</a>
<br><hr><p>
</body>
</html>
}
set content [subst -nobackslashes -nocommands $content]
#puts $content
set f [open $filename w]
puts $f $content
close $f
}
Class XODocCmd -parameter {
{xoDocObj ""}
}
XODocCmd instproc unknown args {
[self] instvar xoDocObj
if {[llength $args] > 1} {
switch [lindex $args 1] {
proc - instproc {
return [eval $xoDocObj handleMethod $args]
}
default {
switch [lindex $args 0] {
@File {
return [$xoDocObj handleFile [lindex $args 1]]
}
default {
return [eval $xoDocObj handleObj $args]
}
}
}
}
}
puts stderr "Unknown documentation: '$args'"
}
XODocCmd @
More information about the Xotcl
mailing list