Version 2 of starDOM
Updated 2002-08-16 10:17:36
Rolf Ade, Richard Suchenwirth 2002-08-16 - starDOM is going to be a little XML browser packaged as a Starkit. Though compact in code, it is quite powerful because it stands on the shoulders of several giants:
- tDOM is the leanest, fastest DOM engine in the (open) market
- BWidgets supply a strong Tree widget here
- and of course Tcl/Tk lay great groundwork for all...
Here is version 0.3 for public code review and discussion, which features cyclic searching in various modes (case-sensitive full text; case-insensitive full-text; regexp; or XPath). Search term goes into the upper entry; <Return> starts the search. With the (...) button you get a file selector for opening. Enjoy, comment, improve!
namespace eval starDOM {
set version 0.3
set about "<about>
<name >starDom</name>
<version >$version</version>
<description>A little XML browser</description>
<authors>
<author>Rolf Ade</author>
<author>Richard Suchenwirth</author>
</authors>
</about>"
}
package require BWidget
package require tdom
proc starDOM::insertNode {w parent node} {
set drawcross "auto"
if {[$node nodeType] != "ELEMENT_NODE"} {
# text, cdata, comment and PI nodes
set text [string map {\n " "} [$node nodeValue]]
} else {
set name "[$node nodeName]"
set text "<$name"
foreach att [$node attributes] {
catch {append text " $att=\"[$node getAttribute $att]\""}
}
append text ">"
if {[$node hasChildNodes]} {
set children [$node childNodes]
if {[llength $children]==1 && [$children nodeName]=="#text"} {
append text [string map {\n " "} [$children nodeValue]] </$name>
} else {
set drawcross "allways" ;# bad English, but needed by BWidget
}
}
}
$w insert end $parent $node -text $text -drawcross $drawcross
}
proc starDOM::showNode {w nodes} {
variable next; variable hilited; variable info
set nr $next
set nrOfNodes [llength $nodes]
set node [lindex $nodes $nr]
if {($nr + 1) == $nrOfNodes} {
set next 0
} else {
incr next
}
foreach prevHilited $hilited {$w itemconfigure $prevHilited -fill black}
set hilited {}
set info [expr {$nr+1}]/$nrOfNodes
set ancestorNodes [$node selectNodes ancestor::*]
foreach ancestor $ancestorNodes {
openCross $w $ancestor
$w itemconfigure $ancestor -open 1
}
set parent [$node parentNode]
set children [$parent childNodes]
if {[llength $children]==1 && [$children nodeName]=="#text"} {
set node $parent
}
$w itemconfigure $node -fill "blue"
$w see $node
$w xview moveto 0 ;# scroll to flush left
lappend hilited $node
}
proc starDOM::search {w} {
variable mode; variable query; variable info;
variable changed; variable next; variable root
switch -- $mode {
case -
XPath {
set q [expr {$mode=="case"? "//text()\[contains(.,'$query')\]": $query}]
set nodes [$root selectNodes $q]
}
nocase -
regexp {
set allText [$root selectNodes //text()]
set nodes {}
if {$mode == "nocase"} {
set s [string tolower $query]
foreach n $allText {
if {[string first $s [string tolower [$n nodeValue]]]>=0} {
lappend nodes $n
}
}
} else {
foreach n $allText {
if {[regexp $query [$n nodeValue]]} {
lappend nodes $n
}
}
}
}
}
set nrOfNodes [llength $nodes]
set info "$nrOfNodes hit(s)"
if {$nrOfNodes} {
if $changed {set next 0; set changed 0}
showNode $w $nodes
}
}
proc starDOM::openCross {w node} {
if {[$w itemcget $node -drawcross] == "allways"} {
foreach child [$node childNodes] {
insertNode $w $node $child
}
$w itemconfigure $node -drawcross "auto"
}
}
proc starDOM::Open {w {filename ""}} {
if {$filename == ""} {
set filename [tk_getOpenFile -filetypes {
{{XML file} *.xml} {{All files} *.*}}]
}
if {$filename != ""} {
starDOM::show $w $filename
wm title . "$filename - starDOM"
}
}
proc starDOM::show {w string {isText 0}} {
variable hilited {} root
if {!$isText} {
set fd [tDOM::xmlOpenFile $string]
set doc [dom parse -channel $fd]
close $fd
} else {
set doc [dom parse $string]
}
$doc documentElement root
$w delete [$w nodes root]
insertNode $w root $root
openCross $w $root ;# Show children of root right after startup
$w itemconfigure $root -open 1
}
proc starDOM::UI {} {
variable changed 0 mode "case" query "" info ""
frame .f
button .f.open -text ... -command {starDOM::Open .t} -pady 0\
-borderwidth 1
entry .f.e -width 25 -textvar starDOM::query
bind .f.e <Key> {set starDOM::changed 1}
bind .f.e <Return> {starDOM::search .t}
foreach {txt} {case nocase regexp XPath} {
radiobutton .f.r$txt -text $txt -variable starDOM::mode \
-value $txt -padx 0
}
label .f.info -textvar starDOM::info -width 10
eval pack [winfo children .f] -side left -padx 0
pack .f.e -fill x -expand 1
Tree .t -yscrollcommand ".y set" -xscrollcommand ".x set" -padx 0 \
-opencmd "starDOM::openCross .t" -height 24
scrollbar .x -ori hori -command ".t xview"
scrollbar .y -ori vert -command ".t yview"
grid .f - -sticky ew
grid .t .y -sticky news
grid .x -sticky news
grid rowconfig . 1 -weight 1
grid columnconfig . 0 -weight 1
if {$::tcl_platform(platform)=="windows"} {
bind .t.c <MouseWheel> {
%W yview scroll [expr {int(pow(%D/-120,3))}] units
}
focus .t.c
}
}
#---------------------------------------- "main"
starDOM::UI
if {[llength $argv]} {
starDOM::show .t [lindex $argv 0]
} else {
starDOM::show .t $starDOM::about 1
}