[Xotcl] some xodoc fixes
Kristoffer Lawson
setok at fishpool.com
Tue Feb 13 03:42:45 CET 2001
I'm not sure if I should send this to Uwe and Gustaf directly or this
list, so if this is wasting bandwidth then tell me and I'll try to
remember to send further suggested updates directly to them. Anyhow
here are some changes I made:
- It bugged when a file did not end with a newline (this was actually the
cause of my earlier problem).
- Slightly changed the errorCode documentation section.
- Fixed some other HTML bugs (quite possibly caused by my previoues
ventures into playing with xodoc ;-).
- Removed a lot of space that was being fed out. This was problematic
when I use the <pre> tags. The downside is that the code looks rather
messy, but I might just be posting a kind of solution for that soon.
Anyhow, my version of the xodoc file is attached here.
- ---------- = = ---------//--+
| / 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] {
append c "<tr>"
if {[[self] exists $p]} {
append c "<td valign=\"top\">"
append c "<em>" [[self] capitalize $p] ":</em>"
if {[string equal $p "errorCodes"]} {
# Build table with list of error codes.
append c "<td>"
# append c "<table border=1>"
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 "<b>$code</b>: $desc\n<p>"
}
# append c "</table>\n"
} else {
append c "<td>"
append c [[self] reflowHTML " " [[self] set $p]]
}
}
}
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 "<table>"
append c "[[self] getDocPropertiesHTML] <br>\n"
append c "</table>"
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" "<table>"\
[[self] getDocPropertiesHTML] "</table>"
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] "
set argText "<table>\n"
if {[[self] exists arguments]} {
set argText "<table>\n"
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
append c " </b><p>\n" \
$argText [[self] getDocPropertiesHTML] </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]
set c [string range $c [expr $line + 1] end]
if {[info complete $cmd]} {
set r $cmd; set cmd ""
return $r
}
} elseif {[string length [string trim $c]] >0} {
# We have some data left which doesn't end with a "\n". This happens
# if an EOF marks the end of a line instead of a newline.
append cmd $c
set c ""
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