IDETclToHtml.xotcl
package provide IDETclToHtml 0.1
package require IDETclParser
Class PrsMarkupVisitor
@ PrsMarkupVisitor idemeta categories api
@ PrsMarkupVisitor idemeta categoriesMethods {{generateIndexAll generateSignatures generateBackReferences generateABCIndex collectMarkups initNewFile generateFrontFile}}
@ PrsMarkupVisitor idemeta component IDETclToHtml
PrsMarkupVisitor instproc addDef elem {
my instvar definitions fileName definitionsKey currentDefs varLocalDefinitions
set def [$elem set def]
set varLocalDefinitions [list]
lappend currentDefs $def
if {$def ni $definitionsKey} {
lappend definitions [list $def [$elem set begin] $fileName]
lappend definitionsKey $def
}
}
PrsMarkupVisitor instproc addGlobalRefs {elem ref} {
my instvar globalRefsArr fileName definitionsKey definitions packageRefs
if {[lindex $ref 0] eq "package"} {
set packageName [lindex $ref 1]
if {[catch {set packageRefs($fileName)} reqPackages]} {
lappend packageRefs($fileName) $packageName
} else {
if {$packageName ni $reqPackages} {
lappend packageRefs($fileName) $packageName
}
}
}
set r [lsearch $definitionsKey $ref]
if {$r<0} {
return
}
set defElem $elem
while {[Object isobject $defElem] && [$defElem hasclass PrsElement] && ![$defElem exists def]} {
set defElem [$defElem info parent]
}
if {[Object isobject $defElem] && [$defElem exists def]} {
set d [$defElem set def]
if {[lindex $ref 0] eq "object" && [lindex $d 0] eq "method" && [lindex $ref 1] eq [lindex $d 1 0]} {
return
}
set bref [list $d]
} else {
set linkSourceFileName [lindex $definitions $r 2]
if {$linkSourceFileName eq $fileName} {
return
}
set bref [list $fileName [my fileToHtmlFile $fileName]]
}
if {[catch {set globalRefsArr($ref)} brefs]} {
set globalRefsArr($ref) [list $bref]
} else {
if {$bref ni $brefs} {
lappend globalRefsArr($ref) $bref
}
}
}
PrsMarkupVisitor instproc addNavigation {out {linksHtml {}}} {
$out puts "<nav>$linksHtml"
set outFileName [file tail [$out set fileName]]
set navDef {
front.html {Files Overview}
index-all.html {ABC Index}
classes.html {Class Tree}
packages.html {Packages}
}
foreach {file name} $navDef {
if {$outFileName ne $file} {
$out puts "<a href=\"[$out getRootReference $file]\">$name</a> "
} else {
$out puts $name
}
}
$out puts {<a id="errorRef" href="#?">Errors</a>}
$out puts {</nav>}
}
PrsMarkupVisitor instproc addRef elem {
my instvar currentRefs
set ref [$elem set ref]
set refDesc [list $ref [$elem set begin] [$elem set end]]
if {[$elem exists desc]} {
lappend refDesc [$elem set desc]
}
lappend currentRefs $refDesc
my addGlobalRefs $elem $ref
}
PrsMarkupVisitor instproc collectErrors {} {
my instvar context markups errors fileName errorIndex
foreach err [$context set errors] {
lassign $err begin end message
lappend markups [list $begin $end error $message $errorIndex]
lappend errors [list $fileName $message]
incr errorIndex
}
}
PrsMarkupVisitor instproc collectMarkups {tcontext tfileName} {
my instvar markups fileName refCount currentDefs currentRefs context varLocalDefinitions files
set markups [list]
set currentDefs [list]
set currentRefs [list]
set context $tcontext
set refCount 0
set fileName $tfileName
lappend files $tfileName
set varLocalDefinitions [list]
[$context set rootCommand] visit [self]
my collectErrors
}
PrsMarkupVisitor instproc fileToHtmlFile fileName {
return [file rootname $fileName].html
}
PrsMarkupVisitor instproc fileToRelativeHtmlFile {out fileName} {
return [file rootname [$out getRelativeReference $fileName]].html
}
PrsMarkupVisitor instproc generateABCIndex indexOut {
my instvar definitions
my addNavigation $indexOut
$indexOut puts "<h1>All symbols in alphabetical order</h1>"
set indexAll [list]
set r 0
foreach d $definitions {
set type [lindex $d 0 0]
if {$type eq "proc"} {
set name [namespace tail [lindex $d 0 1]]
} elseif {$type eq "method"} {
set name [lindex $d 0 1 2]
} elseif {$type eq "object"} {
set name [namespace tail [lindex $d 0 1]]
} else {
set name [namespace tail [lindex $d 0 1]]
}
lappend indexAll [list $name $d $r]
incr r
}
set firstChar ""
foreach elem [lsort -index 0 -nocase $indexAll] {
lassign $elem name d r
set currFistChar [string toupper [string index $name 0]]
if {$currFistChar ne $firstChar} {
set firstChar $currFistChar
$indexOut puts "<hr><h2>$firstChar</h2>"
}
set type [lindex $d 0 0]
set defFileName [lindex $d 2]
set htmlFile [my fileToHtmlFile $defFileName]
$indexOut puts "<li><a href=\"$htmlFile#r$r\">$name</a> $type"
if {$type eq "proc"} {
set fullName [lindex $d 0 1]
if {[string first : $fullName 2]>0} {
$indexOut puts " $fullName"
}
} elseif {$type eq "method"} {
lassign [lindex $d 0 1] class mtype method
$indexOut puts " $class $mtype"
}
$indexOut puts {</li>}
}
}
PrsMarkupVisitor instproc generateBackReferences fileOut {
my instvar currentDefs definitionsKey definitions globalRefsArr fileName
$fileOut puts {<script class="include" type="text/javascript">
var tclHtmlBackRererences = [}
set first 1
set r 0
foreach def $definitions {
lassign $def d begin defFileName
if {$defFileName eq $fileName} {
if {![catch {set globalRefsArr($d)} brefs]} {
if {!$first} {
$fileOut putsNonewline ,
} else {
set first 0
}
$fileOut putsNonewline "\[\"r$r\",\["
set rFirst 1
foreach bref $brefs {
if {!$rFirst} {
$fileOut putsNonewline ,
} else {
set rFirst 0
}
if {[llength $bref]==1} {
set rdef [lindex $bref 0]
set rdefHumman [my methodDefToHuman $rdef]
set rr [lsearch $definitionsKey $rdef]
if {$rr<0} {
puts "definition not found $rdef"
continue
}
set linkSourceFileName [lindex $definitions $rr 2]
if {$linkSourceFileName eq $fileName} {
set rFileName ""
} else {
set rFileName [my fileToRelativeHtmlFile $fileOut $linkSourceFileName]
set rdefHumman "$linkSourceFileName: $rdefHumman"
}
} else {
lassign $bref rdef rFileName rr
set rdefHumman [my methodDefToHuman $rdef]
set rFileName [my fileToRelativeHtmlFile $fileOut $rFileName]
}
if {$rFileName eq ""} {
$fileOut putsNonewline "\[\"#r$rr\","
} else {
if {$rr ne ""} {
$fileOut putsNonewline "\[\"$rFileName#r$rr\","
} else {
$fileOut putsNonewline "\[\"$rFileName\","
}
}
$fileOut putsNonewline "\"$rdefHumman\"\]"
}
$fileOut putsNonewline "\]\]"
}
}
incr r
}
$fileOut puts {];
</script>
}
}
PrsMarkupVisitor instproc generateClassHierarchy {hierarchyOut repository} {
my instvar definitions
my addNavigation $hierarchyOut
$hierarchyOut puts "<h1>Class Hierarchy</h1>"
$hierarchyOut puts {<ul class="classHierarchy">}
set r 0
foreach d $definitions {
set type [lindex $d 0 0]
set defFileName [lindex $d 2]
if {$type eq "object"} {
set objectName [lindex $d 0 1]
if {[$repository isXotclClass $objectName]} {
set superclasses [$repository getClassSuperclassesFromFullName $objectName]
set objArr($objectName) [list $r $defFileName $superclasses]
foreach s $superclasses {
lappend superArr($s) $objectName
}
}
}
incr r
}
if {[array exists superArr]} {
set needMore 1
set knownObjects [array names objArr]
lappend knownObjects ::xotcl::Object ::itcl::object
while {$needMore} {
set needMore 0
foreach objectName [array names superArr] {
if {$objectName ni $knownObjects} {
set superclasses [$repository getClassSuperclassesFromFullName $objectName]
lappend knownObjects $objectName
foreach s $superclasses {
lappend superArr($s) $objectName
set needMore 1
}
}
}
}
}
set rootObject ::xotcl::Object
if {[info exists superArr($rootObject)]} {
my generateClassHierarchyRek $hierarchyOut $rootObject objArr superArr
}
set rootObject ::itcl::object
if {[info exists superArr($rootObject)]} {
my generateClassHierarchyRek $hierarchyOut $rootObject objArr superArr
}
$hierarchyOut puts {</ul>}
}
PrsMarkupVisitor instproc generateClassHierarchyRek {hierarchyOut rootObject objArr_ref superArr_ref} {
upvar $objArr_ref objArr
upvar $superArr_ref superArr
$hierarchyOut puts <li>
if {![catch {set objArr($rootObject)} rootDesc]} {
lassign $rootDesc r defFileName superclasses
$hierarchyOut puts "<a href=\"[my fileToHtmlFile $defFileName]#r$r\">$rootObject</a>"
} else {
$hierarchyOut puts $rootObject
}
if {![catch {set superArr($rootObject)} subclasses]} {
$hierarchyOut puts <ul>
foreach s $subclasses {
my generateClassHierarchyRek $hierarchyOut $s objArr superArr
}
$hierarchyOut puts </ul>
}
$hierarchyOut puts </li>
}
PrsMarkupVisitor instproc generateErrors errOut {
my instvar errors
$errOut puts {<table class="errors">}
$errOut puts {<tr><th>No</th><th>File</th><th>Message</th></tr>}
set errNo 1
foreach error $errors {
lassign $error file message
$errOut puts "<tr><td>$errNo</td><td><a href=\"[my fileToHtmlFile $file]#e$errNo\" target=\"sourceFrame\">$file</a></td><td>$message</td></tr>"
incr errNo
}
$errOut puts "</table>"
}
PrsMarkupVisitor instproc generateFrontFile frontOut {
my instvar definitions files errors
my addNavigation $frontOut
$frontOut puts "<h1>Files Overview</h1>"
set r 0
set dicproc [dict create]
set dicmethod [dict create]
set dicobject [dict create]
set dicerrors [dict create]
set cproc 0
set cmethod 0
set cobject 0
set cerrors 0
foreach d $definitions {
set type [lindex $d 0 0]
set defFileName [lindex $d 2]
if {$type eq "proc"} {
dict incr dicproc $defFileName
incr cproc
} elseif {$type eq "method"} {
dict incr dicmethod $defFileName
incr cmethod
} elseif {$type eq "object"} {
dict incr dicobject $defFileName
incr cobject
}
}
foreach d $errors {
dict incr dicerrors [lindex $d 0]
incr cerrors
}
$frontOut puts {<table class="fileOverview">}
$frontOut puts {<tr><th>File</th><th>procs</th><th>objects</th><th>methods</th><th>errors</th></tr>}
foreach file [lsort -unique $files] {
$frontOut puts {<tr><td>}
$frontOut puts "<a href=\"[my fileToHtmlFile $file]\">$file</a>"
$frontOut puts {</td><td>}
if {[dict exists $dicproc $file]} {
$frontOut puts [dict get $dicproc $file]
}
$frontOut puts {</td><td>}
if {[dict exists $dicobject $file]} {
$frontOut puts [dict get $dicobject $file]
}
$frontOut puts {</td><td>}
if {[dict exists $dicmethod $file]} {
$frontOut puts [dict get $dicmethod $file]
}
$frontOut puts {</td><td>}
if {[dict exists $dicerrors $file]} {
$frontOut puts [dict get $dicerrors $file]
}
$frontOut puts {</td></tr>}
}
$frontOut puts {<tr><td>sum</td>}
$frontOut puts "<td>$cproc</td><td>$cobject</td><td>$cmethod</td><td>$cerrors</td></tr>"
$frontOut puts "</table>"
$frontOut puts "<hr><small>
generated on [clock format [clock seconds]] by <a href=\"http://www.xdobry.de/ttclcheck\" target=\"_parent\">ttclcheck</a>
<a href=\"http://www.gnu.org\" target=\"_parent\">GPL</a> Software.
(Powered by <a href=\"http://www.tcl.tk\" target=\"_parent\">Tcl</a> and <a href=\"http://www.xotcl.org\" target=\"_parent\">XOTcl</a>)\"
</small>"
}
PrsMarkupVisitor instproc generateIndexAll indexOut {
my instvar definitions
set r 0
set dic [dict create]
foreach d $definitions {
set type [lindex $d 0 0]
set defFileName [lindex $d 2]
if {$type eq "proc"} {
set procname [lindex $d 0 1]
set ns [namespace qualifiers $procname]
if {$ns eq ""} {
set ns ::
} else {
set ns [string trimleft $ns :]
}
set procShort [namespace tail $procname]
dict set dic $type $ns $procShort [list $r $defFileName $procShort]
} elseif {$type eq "method"} {
lassign [lindex $d 0 1] class mtype method
dict set dic $type $class $mtype $method [list $r $defFileName $method]
} elseif {$type eq "object"} {
dict set dic $type [lindex $d 0 1] [list $r $defFileName]
}
incr r
}
my generateSignaturesFromDic $indexOut $dic
}
PrsMarkupVisitor instproc generatePackages packageOut {
my instvar definitions globalRefsArr definitionsKey packageRefs
my addNavigation $packageOut
$packageOut puts "<h1>Packages</h1>"
set packages [list]
set r 0
foreach d $definitions {
set type [lindex $d 0 0]
set defFileName [lindex $d 2]
if {$type eq "package"} {
lappend packages [list [lindex $d 0 1] [lindex $d 2]]
}
}
foreach package [lsort -index 0 $packages] {
lassign $package name file
$packageOut puts <ul>
$packageOut puts "<li><a href=\"[my fileToHtmlFile $file]\">$name</a> $file</li>"
if {![catch {set packageRefs($file)} reqPackages]} {
$packageOut puts <ul>
foreach p $reqPackages {
$packageOut puts "<li>$p</li>"
}
$packageOut puts </ul>
}
$packageOut puts </ul>
}
}
PrsMarkupVisitor instproc generateSigMethods {sigOut dicMethods {class {}}} {
foreach m [lsort [dict keys $dicMethods]] {
set d [dict get $dicMethods $m]
set htmlFile [my fileToHtmlFile [lindex $d 1]]
if {$class ne ""} {
set classAttr " class=\"$class\""
} else {
set classAttr ""
}
$sigOut puts "<li><a href=\"$htmlFile#r[lindex $d 0]\" target=\"sourceFrame\"$classAttr>[string trimleft [lindex $d 2] :]</a></li>"
}
}
PrsMarkupVisitor instproc generateSignatures sigOut {
my instvar fileName definitions
set r 0
set dic [dict create]
foreach d $definitions {
if {[lindex $d 2] eq $fileName} {
set type [lindex $d 0 0]
set defFileName [file tail [lindex $d 2]]
if {$type eq "proc"} {
set procname [lindex $d 0 1]
set ns [namespace qualifiers $procname]
if {$ns eq ""} {
set ns ::
} else {
set ns [string trimleft $ns :]
}
set procShort [namespace tail $procname]
dict set dic $type $ns $procShort [list $r $defFileName $procShort]
} elseif {$type eq "method"} {
lassign [lindex $d 0 1] class mtype method
dict set dic $type $class $mtype $method [list $r $defFileName $method]
} elseif {$type eq "object"} {
dict set dic $type [lindex $d 0 1] [list $r $defFileName]
}
}
incr r
}
my generateSignaturesFromDic $sigOut $dic
}
PrsMarkupVisitor instproc generateSignaturesFromDic {sigOut dic} {
$sigOut puts {<div id="treecontrol"><a href="#?">Collapse All</a> | <a href="#?">Expand All</a></div>}
if {[dict exists $dic proc]} {
$sigOut puts "<h4>Procedures</h4>"
$sigOut puts {<ul class="tv">}
foreach ns [lsort [dict keys [dict get $dic proc]]] {
$sigOut puts "<li><div class=\"hita\"></div>$ns"
$sigOut puts {<ul class="te">}
my generateSigMethods $sigOut [dict get $dic proc $ns]
$sigOut puts {</ul>}
$sigOut puts {</li>}
}
$sigOut puts {</ul>}
}
if {[dict exists $dic method]} {
$sigOut puts "<h4>Objects</h4>"
$sigOut puts {<ul class="tv">}
foreach object [lsort [dict keys [dict get $dic method]]] {
set dicObject [dict get $dic method $object]
set objectName [string trimleft $object :]
if {[dict exists $dic object $object]} {
set d [dict get $dic object $object]
$sigOut puts "<li><div class=\"hita\"></div><a href=\"[my fileToHtmlFile [lindex $d 1]]#r[lindex $d 0]\" target=\"sourceFrame\">$objectName</a>"
} else {
$sigOut puts "<li>>$objectName<li>"
}
set hasElements 0
if {[dict exists $dicObject instproc]} {
set hasElements 1
$sigOut puts {<ul class="te">}
my generateSigMethods $sigOut [dict get $dicObject instproc]
}
if {[dict exists $dicObject proc]} {
if {!$hasElements} {
$sigOut puts {<ul class="te">}
}
my generateSigMethods $sigOut [dict get $dicObject proc] static
set hasElements 1
}
if {$hasElements} {
$sigOut puts {</ul>}
}
$sigOut puts {</li>}
}
$sigOut puts {</ul>}
}
}
PrsMarkupVisitor instproc getCoreLinkForKey refKey {
my instvar tclCommands tkCommands packageArr
set type [lindex $refKey 0]
if {$type eq "proc"} {
set name [string trimleft [lindex $refKey 1] :]
if {$name in $tclCommands} {
return "http://www.tcl.tk/man/tcl8.5/TclCmd/$name.htm"
} elseif {$name in $tkCommands} {
return "http://www.tcl.tk/man/tcl8.5/TkCmd/$name.htm"
}
} elseif {$type eq "object"} {
set objname [lindex $refKey 1]
if {$objname eq "::xotcl::Object"} {
return "http://media.wu.ac.at//doc/langRef-xotcl.html#Object"
} elseif {$objname eq "::xotcl::Class"} {
return "http://media.wu.ac.at//doc/langRef-xotcl.html#Class"
}
} elseif {$type eq "method"} {
lassign [lindex $refKey 1] objname methodtype method
if {$objname eq "::xotcl::Object" && $methodtype eq "instproc" && $method in {abstract append array autoname check class cleanup configure contains copy eval exists extractConfigureArg filter filterguard filtersearch forward getExitHandler hasclass incr info invar isclass ismetaclass ismixin isobject istype lappend mixin move noinit parametercmd procsearch requireNamespace setExitHandler subst trace unset uplevel upvar volatile vwait}} {
return "http://media.wu.ac.at//doc/langRef-xotcl.html#Object-$method"
} elseif {$objname eq "::xotcl::Class" && $methodtype eq "instproc" && $method in {unknown allinstances alloc info instdestroy instfilter instfilterguard instforward instinvar instmixin instparametercmd parameter parameterclass recreate superclass}} {
return "http://media.wu.ac.at//doc/langRef-xotcl.html#Class-$method"
}
} elseif {$type eq "package"} {
set packageName [lindex $refKey 1]
if {![catch {set packageArr($packageName)} ref]} {
return $ref
}
}
return
}
PrsMarkupVisitor instproc getElemContext elem {
if {![Object isobject $elem]} {
my set context
} else {
if {[Object isobject $elem] && [$elem exists context]} {
return [$elem set context]
} else {
return [my getElemContext [$elem info parent]]
}
}
}
PrsMarkupVisitor instproc hasErrors {} {
my instvar errors
expr {[llength $errors]>0}
}
PrsMarkupVisitor instproc init {} {
my set definitionsKey [list]
my set definitions [list]
my set varDefinitions [list]
my set varLocalDefinitions [list]
my set varIndex 0
my set errors [list]
my set errorIndex 1
my set files [list]
my set tkCommands [lsort {bell frame panedwindow tk_focusFollowsMouse toplevel ttk::separator
bind grab photo tk_focusNext ttk::button ttk::sizegrip
bindtags grid place tk_focusPrev ttk::checkbutton ttk::spinbox
bitmap image radiobutton tk_getOpenFile ttk::combobox ttk::style
button keysyms raise tk_getSaveFile ttk::entry ttk::treeview
canvas label scale tk_menuSetFocus ttk::frame ttk::widget
checkbutton labelframe scrollbar tk_messageBox ttk::intro ttk_image
clipboard listbox selection tk_optionMenu ttk::label ttk_vsapi
colors loadTk send tk_popup ttk::labelframe winfo
console lower spinbox tk_setPalette ttk::menubutton wm
cursors menu text tk_textCopy ttk::notebook
destroy menubutton tk tk_textCut ttk::panedwindow
entry message tk_bisque tk_textPaste ttk::progressbar
event option tk_chooseColor tkerror ttk::radiobutton
focus options tk_chooseDirectory tkvars ttk::scale
font pack tk_dialog tkwait ttk::scrollbar}]
my set tclCommands [lsort {tell socket subst open eof pwd glob list pid exec auto_load_index time unknown eval lassign lrange fblocked lsearch auto_import gets case lappend variable llength auto_execok linsert error catch clock info split array fconfigure concat join lreplace source fcopy global switch auto_qualify update close cd auto_load file append lrevers e format unload read package binary namespace scan apply trace seek zlib chan flush after vwait dict uplevel lset rename rechan fileevent regexp lrepeat upvar encoding expr unset load regsub history interp exit lsort tclLog string}]
my array set packageArr {
tk http://www.tcl.tk/man/tcl8.5/TkCmd/contents.htm
mysqltcl http://www.xdobry.de/mysqltcl/
XOTcl http:://www.xotcl.org
tdom http:://www.tdom.org
Itcl http://incrtcl.sourceforge.net/itcl/
sqlite3 http://www.sqlite.org/tclsqlite.html
tcom http://www.vex.net/~cthuang/tcom/
}
}
PrsMarkupVisitor instproc initNewFile {} {
my instvar varLocalDefinitions varDefinitions varIndex
set varIndex 0
set varDefinitions [list]
set varLocalDefinitions [list]
}
PrsMarkupVisitor instproc initPass2 {} {
my instvar globalRefsArr errors errorIndex
set errors [list]
set errorIndex 1
}
PrsMarkupVisitor instproc insertHtmlMarkups {content out} {
my instvar markups fileName currentDefs definitionsKey currentRefs definitions
set insertions [list]
set insertionsEnd [list]
foreach d $currentDefs {
set r [lsearch $definitionsKey $d]
if {$r>=0} {
lappend insertions [list [lindex $definitions $r 1] "<a name=\"r$r\">"]
}
}
foreach m $markups {
lassign $m begin end markup varType varIndex
if {$varIndex ne ""} {
set dataVarIndex " data-vindex=\"$varIndex\""
} else {
set dataVarIndex ""
}
if {$markup eq "error"} {
lappend insertions [list $begin "<a class=\"$markup\" name=\"e$varIndex\" data-type=\"$varType\">"]
lappend insertionsEnd [list [expr {$end+1}] "</a>"]
} else {
if {$varType ne ""} {
lappend insertions [list $begin "<span class=\"$markup\" data-type=\"$varType\"$dataVarIndex>"]
} else {
lappend insertions [list $begin "<span class=\"$markup\"$dataVarIndex>"]
}
lappend insertionsEnd [list [expr {$end+1}] "</span>"]
}
}
foreach ref $currentRefs {
lassign $ref key begin end methodDesc
set r [lsearch $definitionsKey $key]
if {$r>=0} {
set refFileName [lindex $definitions $r 2]
if {$refFileName ne $fileName && $refFileName ne ""} {
set url [my fileToRelativeHtmlFile $out $refFileName]
} else {
set url ""
}
append url #r$r
if {$methodDesc ne ""} {
lappend insertions [list $begin "<a href=\"$url\" title=\"[my methodDescToHuman $methodDesc]\">"]
} else {
lappend insertions [list $begin "<a href=\"$url\">"]
}
lappend insertions [list [expr {$end+1}] "</a>"]
} else {
set coreLink [my getCoreLinkForKey $key]
if {$coreLink ne ""} {
lappend insertions [list $begin "<a class=\"ext\" href=\"$coreLink\" target=\"_blank\">"]
lappend insertions [list [expr {$end+1}] "</a>"]
}
}
}
lappend insertions {*}$insertionsEnd
set insertions [lsort -index 0 -integer $insertions]
set start 0
set ret ""
foreach i $insertions {
lassign $i pos icontent
if {$pos>0} {
append ret [string map {> > < < & & \t " "} [string range $content $start [expr {$pos-1}]]]
}
append ret $icontent
set start $pos
}
append ret [string map {> > < < & & \t " "} [string range $content $start end]]
$out putsNonewline $ret
}
PrsMarkupVisitor instproc markup {elem type} {
my instvar markups
lappend markups [list [$elem set begin] [$elem set end] $type]
}
PrsMarkupVisitor instproc markupVariable {elem type} {
my instvar markups varLocalDefinitions varDefinitions varIndex
set elemContext [my getElemContext $elem]
set varName [$elem getVariableName]
lassign [$elemContext getVariableDesc $varName] varType varScope
if {[lindex $varScope 0] ne "local"} {
set fullVarName [concat $varName $varScope]
append type " [lindex $varScope 0]"
set index [lsearch -index 0 $varDefinitions $fullVarName]
if {$index<0} {
set myIndex $varIndex
incr varIndex
lappend varDefinitions [list $fullVarName $myIndex]
} else {
set myIndex [lindex $varDefinitions $index 1]
}
} else {
set index [lsearch -index 0 $varLocalDefinitions $varName]
if {$index<0} {
set myIndex $varIndex
incr varIndex
lappend varLocalDefinitions [list $varName $myIndex]
} else {
set myIndex [lindex $varLocalDefinitions $index 1]
}
}
if {[lindex $varType 0] ni {unknown def {}}} {
lappend markups [list [$elem set begin] [$elem set end] $type $varType $myIndex]
} else {
lappend markups [list [$elem set begin] [$elem set end] $type {} $myIndex]
}
}
PrsMarkupVisitor instproc methodDefToHuman def {
switch -exact -- [lindex $def 0] {
method {
lassign [lindex $def 1] class type method
if {$type ne "instproc"} {
return "$class $type>$method"
} else {
return "$class>$method"
}
}
proc {
return [lindex $def 1]
}
default {
return $def
}
}
}
PrsMarkupVisitor instproc methodDescToHuman methodDesc {
return $methodDesc
}
PrsMarkupVisitor instproc visit elem {
if {[$elem hasclass PrsVariable] || [$elem hasclass PrsVariableRef]} {
my markupVariable $elem variable
} elseif {[$elem hasclass PrsCommand]} {
set first [$elem getElem 0]
if {[$first hasclass PrsLiteral]} {
my markup $first command
}
} elseif {[$elem hasclass PrsQuoted] && [$elem hasQuote]} {
my markup $elem quote
} elseif {[$elem hasclass PrsComment]} {
my markup $elem comment
}
if {[$elem exists def]} {
my addDef $elem
}
if {[$elem exists ref]} {
my addRef $elem
}
}
@ Class Tcl2HTML {
description {Start Class for converting tcl code to pretty html site}
}
Class Tcl2HTML -superclass ::PrsFileContext
@ Tcl2HTML idemeta categories app-start
@ Tcl2HTML idemeta categoriesMethods parseArgs
@ Tcl2HTML idemeta component IDETclToHtml
Tcl2HTML instproc cleanupSubcontext subcontext {
}
Tcl2HTML instproc generateSignatures {} {
my instvar sigOut
my @markup generateSignatures $sigOut
}
Tcl2HTML instproc getPathTruncateFile file {
my instvar pathTruncateCount
file join {*}[lrange [file split $file] $pathTruncateCount end]
}
Tcl2HTML instproc handleGlobalComment comment {
next
my instvar parseMode htmlOut
if {$parseMode eq "report"} {
if {[string trim $comment] ne ""} {
$htmlOut putsNonewline {<span class='comment'>}
$htmlOut putsNonewlineMasked $comment
$htmlOut putsNonewline {</span>}
} else {
$htmlOut putsNonewlineMasked $comment
}
}
}
Tcl2HTML instproc init {} {
next
my initMarkup
}
Tcl2HTML instproc initMarkup {} {
PrsMarkupVisitor create [self]::@markup
}
Tcl2HTML instproc initPass2 {} {
next
my @markup initPass2
}
Tcl2HTML instproc initPathTruncate files {
my instvar pathTruncateCount
set pathTruncateCount 0
set filesPaths [list]
foreach f $files {
lappend filesPaths [file split $f]
}
while 1 {
set match 1
set first 1
foreach fp $filesPaths {
if {$pathTruncateCount+1>=[llength $fp]} {
set match 0
break
}
if {$first} {
set currentPath [lindex $fp $pathTruncateCount]
set first 0
} else {
if {$currentPath ne [lindex $fp $pathTruncateCount]} {
set match 0
break
}
}
}
if {$match} {
incr pathTruncateCount
} else {
break
}
}
}
Tcl2HTML instproc openTestFile {} {
my parseFiles [list temptest.tcl]
}
Tcl2HTML instproc parseArgs arguments {
set elem [lindex $arguments 0]
if {$elem eq "-od"} {
if {[llength $arguments]<2} {
error "expect argument for option -od"
}
set outDir [lindex $arguments 1]
if {![file isdir $outDir]} {
file mkdir $outDir
}
my set outDir $outDir
return 2
} elseif {$elem eq "-noerror"} {
my set noerror 1
return 1
}
return 0
}
Tcl2HTML instproc parseFile file {
my instvar markups htmlOut filesOut parseMode sigOut outDir
if {$parseMode eq "report"} {
set markups [list]
set htmlFile [file rootname [my getPathTruncateFile $file]].html
set htmlOut [TclHtmlBuilder new -childof [self] $outDir $htmlFile]
set sigFile [file rootname [my getPathTruncateFile $file]]_sig.html
set sigOut [TclHtmlBuilder new -childof [self] $outDir $sigFile]
$sigOut printHtmlHeader "Tcl Source (Tcl2HTML)" "<script class=\"include\" type=\"text/javascript\" src=\"[$sigOut getRootReference jquery-1.5.1.js]\"></script>"
$sigOut puts "<h3>$file</h3>"
$filesOut puts "<a href=\"$sigFile\" target=\"signatureFrame\" data-source=\"$htmlFile\">[my getPathTruncateFile $file]</a><br>"
$htmlOut printHtmlHeader $file "<script class=\"include\" type=\"text/javascript\" src=\"[$htmlOut getRootReference jquery-1.5.1.js]\"></script>"
my @markup addNavigation $htmlOut "<a href=\"[$htmlOut getRelativeReference $sigFile]\" target=\"signatureFrame\">Outline</a> "
$htmlOut puts "<h1>[my getPathTruncateFile $file]</h1>
<pre>"
my @markup initNewFile
next
$htmlOut puts {</pre>}
my @markup generateBackReferences $htmlOut
$htmlOut puts "<script class=\"include\" type=\"text/javascript\" src=\"[$htmlOut getRootReference tclhtml-file.js]\"></script>"
my generateSignatures
$sigOut puts "<script class=\"include\" type=\"text/javascript\" src=\"[$sigOut getRootReference tclhtml-sig.js]\"></script>"
$sigOut closeAndDestroy
$htmlOut closeAndDestroy
} else {
next
}
}
Tcl2HTML instproc parseFiles files {
my instvar filesOut outDir repository
my prepareOutDir
my initPathTruncate $files
set filesOut [TclHtmlBuilder new -childof [self] $outDir "files.html"]
$filesOut printHtmlHeader {Tcl Source (Tcl2HTML)} {<script class="include" type="text/javascript" src="jquery-1.5.1.js"></script>}
$filesOut puts "<a href=\"all.html\" target=\"signatureFrame\">All</a><br>"
next
$filesOut puts {<script class="include" type="text/javascript" src="tclhtml-files.js"></script>}
$filesOut closeAndDestroy
set allFileOut [TclHtmlBuilder new -childof [self] $outDir "all.html"]
$allFileOut printHtmlHeader All {<script class="include" type="text/javascript" src="jquery-1.5.1.js"></script>}
$allFileOut puts "<h3>All Files</h3>"
my @markup generateIndexAll $allFileOut
$allFileOut puts {<script class="include" type="text/javascript" src="tclhtml-sig.js"></script>}
$allFileOut closeAndDestroy
set fontFileOut [TclHtmlBuilder new -childof [self] $outDir "front.html"]
$fontFileOut printHtmlHeader "Files Overview"
my @markup generateFrontFile $fontFileOut
$fontFileOut closeAndDestroy
set indexAllOut [TclHtmlBuilder new -childof [self] $outDir "index-all.html"]
$indexAllOut printHtmlHeader "Index All"
my @markup generateABCIndex $indexAllOut
$indexAllOut closeAndDestroy
set classTreeOut [TclHtmlBuilder new -childof [self] $outDir "classes.html"]
$classTreeOut printHtmlHeader "Classes Tree"
my @markup generateClassHierarchy $classTreeOut $repository
$classTreeOut closeAndDestroy
set packagesOut [TclHtmlBuilder new -childof [self] $outDir "packages.html"]
$packagesOut printHtmlHeader "Packages"
my @markup generatePackages $packagesOut
$packagesOut closeAndDestroy
set errorsOut [TclHtmlBuilder new -childof [self] $outDir "errors.html"]
$errorsOut printHtmlHeader "Errors"
my @markup generateErrors $errorsOut
$errorsOut closeAndDestroy
}
Tcl2HTML instproc parsePartGlobal script {
next
my instvar htmlOut parseMode fileName errors noerror
if {[info exists noerror] && $noerror} {
set errors [list]
}
if {$parseMode eq "report"} {
my @markup collectMarkups [self] [my getPathTruncateFile $fileName]
my @markup insertHtmlMarkups $script $htmlOut
} else {
my @markup collectMarkups [self] [my getPathTruncateFile $fileName]
}
}
Tcl2HTML instproc prepareOutDir {} {
my instvar outDir
if {![info exists outDir]} {
set outDir ""
return
}
set rooDir [PrsCheckerOptions getRootDir]
foreach f {tcl2html.css jquery-1.5.1.js tclhtml-files.js tclhtml-file.js tclhtml-sig.js tclhtml-index.js index.html} {
file copy -force [file join $rooDir $f] [file join $outDir $f]
}
file mkdir [file join $outDir images]
foreach f [glob -directory [file join $rooDir images] *] {
file copy -force $f [file join $outDir images [file tail $f]]
}
}
Tcl2HTML instproc printHtmlFooter htmlOut {
puts $htmlOut "</pre>
</body>
</html>"
}
Tcl2HTML instproc printHtmlHeader {outstream title {headeradds {}}} {
puts $outstream "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">
<html>
<head>
<meta name=\"Language\" content=\"en\">
<meta http-equiv=\"Content-Type\" content=\"text/html; charset=utf-8\">
<title>$title</title>
<link rel=\"stylesheet\" type=\"text/css\" href=\"tcl2html.css\">
$headeradds
</head>
<body>
"
}
Tcl2HTML proc startFromShell arguments {
set fileContext [Tcl2HTML new]
$fileContext startWithArgs $arguments
}
Class TclHtmlBuilder
@ TclHtmlBuilder idemeta component IDETclToHtml
TclHtmlBuilder instproc closeAndDestroy {} {
my printHtmlFooter
my closeFile
my destroy
}
TclHtmlBuilder instproc closeFile {} {
my instvar out
if {[info exists out]} {
close $out
unset out
}
}
TclHtmlBuilder instproc getRelativeReference linkName {
my instvar rootBackReference fileName
set deep [expr {[llength [file split $fileName]]-1}]
set fileSplit [file split $fileName]
set linkSplit [file split $linkName]
set common 0
foreach linkDir $linkSplit fileDir $fileSplit {
if {$linkDir ne $fileDir} {
break
}
incr common
}
if {$deep<$common} {
return [lindex $linkSplit end]
}
if {$common!=$deep} {
if {$common>0} {
file join {*}[lrepeat [expr {$deep-$common}] ..] {*}[lrange $linkSplit $common end]
} else {
file join {*}[lrepeat $deep ..] $linkName
}
} else {
file join {*}[lrange $linkSplit $common end]
}
}
TclHtmlBuilder instproc getRootReference linkName {
my instvar rootBackReference
file join $rootBackReference $linkName
}
TclHtmlBuilder instproc init {outDir _fileName} {
my instvar rootBackReference fileName
set fileName $_fileName
set deep [expr {[llength [file split $fileName]]-1}]
if {$deep>=1} {
set rootBackReference [file join {*}[lrepeat $deep ..]]
} else {
set rootBackReference ""
}
if {$outDir ne ""} {
set fullFileName [file join $outDir $fileName]
set parent [file dirname $fullFileName]
if {$parent ne "" && ![file isdirectory $parent]} {
file mkdir $parent
}
} else {
set rootBackReference ""
set fullFileName $fileName
}
my openFile $fullFileName
}
TclHtmlBuilder instproc openFile fileName {
my instvar out
if {[info exists out]} {
error "html out file already opened"
}
set out [open $fileName w]
fconfigure $out -encoding utf-8
}
TclHtmlBuilder instproc printHtmlFooter {} {
my instvar out
puts $out {</body>
</html>}
}
TclHtmlBuilder instproc printHtmlHeader {title {headeradds {}}} {
my instvar out
puts $out "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">
<html>
<head>
<meta name=\"Language\" content=\"en\">
<meta http-equiv=\"Content-Type\" content=\"text/html; charset=utf-8\">
<meta name=\"generator\" content=\"ttclcheck\">
<meta name=\"date\" content=\"[clock format [clock seconds] -format {%Y-%m-%dT%H:%M:%S}]\">
<title>$title</title>
<link rel=\"stylesheet\" type=\"text/css\" href=\"[my getRootReference tcl2html.css]\">
$headeradds
</head>
<body>
"
}
TclHtmlBuilder instproc puts text {
my instvar out
puts $out $text
}
TclHtmlBuilder instproc putsNonewline text {
my instvar out
puts -nonewline $out $text
}
TclHtmlBuilder instproc putsNonewlineMasked text {
my putsNonewline [string map {> > < < & & \t " "} $text]
}