- tDOM is the leanest, fastest DOM engine in the (open) market
- BWidget supplies a strong Tree widget here
- and of course Tcl/Tk lay great groundwork for all...
See Also edit
- Another version of the starDOM XML editor
- AM: I derived another version of this little tool that allows me a more structured editing of the attributes. It also has proper menus besides the toolbar. Not completely finished
Description edit
Here is version 0.42 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! Last changes:- Now uses BWidget icons and DynamicHelp balloons
- New button "text" to view document source. Brings up a new toplevel with editable text widget. <Control-space> parses text contents in the tree window - a good way to experiment with XML well-formedness (adding this feature to this "XML playstation" took a single line of code ;-)
- New button "New" brings up an empty editable text as above
- New button "Save" turns this into a crude XML editor - edit the source, parse for well-formedness, then save (pretty-printed, because the "$root asXML" output is written to disk ;-)
- Uses BWidget combo enhancements from Enhancing BWidget
- "Find" entry now with history (pop-up or <Up>/<Down>
- "Mode" changed from radiobuttons to chooser combo. Added "eval" mode for direct input of Tcl commands - first 70 chars of result go to Info label, the whole output to stdout
- Generally added ".../all" search modes, to highlight all matches at once. But that may take its time..
- - New "style" chooser: regular, -simple, -html (see tDOM docu)
- comments are marked with <!-- ... --> and greyed out
- Clicking on a node selects it and displays XPath name, number of children, text length in Info label
Code edit
#! /bin/env tclsh
package require Tk
package require BWidget
package require tdom
namespace eval ComboBox {#needed to extend BWidget functionality}
proc ComboBox::enable {w what args} {
switch -- $what {
history {
$w configure -values {{}} ;# always keep a blank on top
foreach evt {<Return> <FocusOut>} {
$w bind $evt {+ ComboBox::_add %W [%W cget -text]}
}
}
chooser {
set values [$w cget -values]
set width 0
foreach i $values {
set sl [string length $i]
if {$sl > $width} {set width $sl}
}
set bg [[label .dummy] cget -bg]
destroy .dummy
$w setvalue first
$w configure -width [expr {$width+1}]
$w configure -editable 0 -relief flat -entrybg $bg
}
}
if {$args != ""} {eval [list $w configure] $args}
}
proc ComboBox::_add {w item} {
set w [winfo parent $w] ;# binding comes from entry
set values [$w cget -values]
if {[lsearch -exact $values $item] < 0} {
$w configure -values [linsert $values 1 $item]
}
}
namespace eval starDOM {
set version 0.42
set about "<about xmlns:foo=\"http://foo.bar/grill\">
<!-- demo, self-test, rudimentary documentation -->
<?Tcl toplevel .greeting; button .greeting.b -text \"Isn't it nice\" \
-command {destroy .greeting}; pack .greeting.b ?>
<name >starDOM</name>
<version >$version</version>
<description lang=\"en\">A little XML browser - now equipped with a rather long description string to try out the popup feature</description>
<uses>
<pkg>Tk [package require Tk]</pkg>
<pkg>BWidget [package require BWidget]</pkg>
<pkg>tdom [package require tdom]</pkg>
</uses>
<authors foo:test=\"ok?\">
<author>Rolf Ade</author>
<author>Richard Suchenwirth</author>
</authors>
</about>"
}
#------------------------------------------ PROCEDURE DIVISION.
proc starDOM::attName att {
if {[llength $att] != 3} {return $att}
if {[lindex $att 2] == {}} {
set attName "xmlns"
if {[lindex $att 1] != {}} {
append attName : [lindex $att 1]
}
return $attName
} else {
return [lindex $att 1]:[lindex $att 0]
}
}
proc starDOM::Eval {query} {
variable info
catch {uplevel #0 $query} res ;# execute any Tcl command
puts "% $query\n$res"
if {[string length $res]>70} {set res [string range $res 0 69]...}
set info $res
}
proc starDOM::insertNode {w parent node} {
set drawcross "auto"
set fill "black"
switch [$node nodeType] {
"ELEMENT_NODE" {
set text "<[$node nodeName]"
foreach att [$node attributes] {
if {[llength $att] == 3} { #(1)..
if {[lindex $att 2] == {}} {
set attName "xmlns"
if {[lindex $att 1] != {}} {
append attName ":[lindex $att 1]"
}
} else {
set attName "[lindex $att 1]:[lindex $att 0]"
}
} else {
set attName $att
} ;#..(1)
append text " $attName=\"[$node getAttribute $attName]\""
}
append text ">"
if {[$node hasChildNodes]} {
set children [$node childNodes]
if {[llength $children]==1 && [$children nodeName]=="#text"} {
append text [string map {\n " "} [$children nodeValue]]
} else {
set drawcross "allways" ;# bad English, wanted by BWidget
}
}
}
"TEXT_NODE" {
set text [string map {\n " "} [$node nodeValue]]
}
"COMMENT_NODE" {
set text "<!--[string map {\n " "} [$node nodeValue]]-->"
set fill "grey50"
}
"PROCESSING_INSTRUCTION_NODE" {
set text "<?[$node target] [string map {\n "" } [$node data]]?>"
set fill "grey50"
}
}
$w insert end $parent $node -text $text -fill $fill -drawcross $drawcross
}
proc starDOM::nodeInfo {w node {prefix ""}} {
variable info
if {[info command $node]==""} return
set info "$prefix$node: [$node toXPath]"
append info " - [llength [$node childNodes]] child(ren)"
catch {append info " - [string length [$node text]] text chars"}
}
proc starDOM::nodeText {w node} {
set text [$w itemcget n:$node -text]
set w2 .[clock clicks]
toplevel $w2
wm title $w2 $node
pack [text $w2.0 -width 50 -height 20 -wrap word -bg lightyellow]
$w2.0 insert end $text
}
proc starDOM::openCross {w {node ""}} {
if {$node == ""} {set node [$w selection get]}
if {[$w itemcget $node -drawcross] == "allways"} {
foreach child [$node childNodes] {
insertNode $w $node $child
}
$w itemconfigure $node -drawcross "auto"
}
}
proc starDOM::openFile {w {filename ""}} {
variable info
if {$filename == ""} {
set filename [tk_getOpenFile -filetypes {
{{XML file} *.xml} {{HTML file} *.html} {{All files} *.*}}]
}
if {$filename != ""} {
cd [file dir $filename] ;# so later opens will start here
wm title . "$filename - starDOM"
starDOM::showTree $w $filename
set info "Loaded $filename - [file size $filename] bytes"
}
}
proc starDOM::save {{filename ""}} {
variable root; variable info
if {$filename == ""} {set filename [lindex [wm title .] 0]}
set filename [tk_getSaveFile -filetypes {
{{XML file} *.xml} {{HTML file} *.html} {{All files} *.*}
} -initialfile $filename -defaultextension .xml]
if {$filename != ""} {
set fp [open $filename w]
$root asXML -channel $fp
close $fp
wm title . "$filename - starDOM"
set info "Saved $filename - [file size $filename] bytes"
}
}
proc starDOM::search {w} {
variable mode; variable query; variable info;
variable changed; variable next; variable root
variable nodes
if {$changed} {
switch -- $mode {
case - case/all -
XPath - XPath/all {
set q [expr {$mode=="case" || $mode == "case/all" ?
"descendant-or-self::text()\[contains(.,'$query')\]"
: $query}]
set t [time {set nodes [$root selectNodes $q]}]
}
nocase - nocase/all -
regexp - regexp/all {
set nodes {}
if {$mode == "nocase" || $mode == "nocase/all"} {
set s [string tolower $query]
set cond {[string first $s [string tolo [$n nodeValue]]]>=0}
} else {
set cond {[regexp $query [$n nodeValue]]}
}
foreach n [$root selectNodes //text()] {
if $cond {lappend nodes $n}
}
}
eval {return [Eval $query]}
}
set changed 0
set next [expr {[string first /all $mode] >= 0 ? -1: 0}]
}
if {[llength $nodes]} {
showNode $w
} else {set info "Not found."}
}
proc starDOM::showNode w {
variable next; variable hilited; variable info; variable nodes
foreach hinode $hilited {$w itemconfigure $hinode -fill black}
set hilited {}
set nrOfNodes [llength $nodes]
if {$next == -1} {
set nr 0; set nrmax [expr {$nrOfNodes - 1}]
} else {
set nr $next; set nrmax $next
nodeInfo $w [lindex $nodes $nr] "[expr {$nr+1}]/$nrOfNodes - "
if {($nr + 1) == $nrOfNodes} {
set next 0
} else {
incr next
}
}
while {$nr <= $nrmax} {
set node [lindex $nodes $nr]
if {$node==""} break
foreach ancestor [$node selectNodes ancestor::*] {
openCross $w $ancestor
$w itemconfigure $ancestor -open 1
}
set parent [$node parentNode]
set sibs [$parent childNodes]
if {[llength $sibs]==1 && [$sibs nodeName]=="#text"} {
set node $parent
}
$w itemconfigure $node -fill blue
if {$next > -1} {$w see $node}
lappend hilited $node
incr nr
}
}
proc starDOM::showTree {w string {isText 0}} {
variable hilited {} root
variable style
raise [winfo toplevel $w]
if {$root != ""} {
[$root ownerDocument] delete
set root "" ;# in case later parsing fails
}
$w delete [$w nodes root]
$w selection clear
if {!$isText && $style == ""} {
set fd [tDOM::xmlOpenFile $string]
set doc [eval dom parse $style -channel $fd]
close $fd
} else {
if {!$isText} {
set fd [open $string]
set string [read $fd]
close $fd
}
set doc [eval dom parse $style [list $string]]
}
set root [$doc documentElement]
insertNode $w root $root
openCross $w $root ;# Show children of root right after startup
$w itemconfigure $root -open 1
}
proc starDOM::viewSource {{fn ""}} {
variable root
if {$fn == ""} {set fn [lindex [wm title .] 0]}
catch {destroy .vs}
toplevel .vs
wm title .vs "$fn - source"
bind .vs <Control-space> {starDOM::showTree .t [.vs.t get 1.0 end] 1}
text .vs.t -wrap word -yscrollcommand ".vs.y set"
scrollbar .vs.y -ori vert -command ".vs.t yview"
pack .vs.y -side right -fill y
pack .vs.t -fill both -expand 1
if {[file exists $fn]} {
set fp [open $fn]
.vs.t insert 1.0 [read $fp]
close $fp
} elseif {$fn != "Untitled"} {.vs.t insert 1.0 [$root asXML]}
if {0} {
if {[.t selection get] != ""} {
set node [.t selection get]
set toPath [$node toXPath]
dom setStoreLineColumn 1
set tmpdoc [dom parse [.vs.t get 1.0 end]]
dom setStoreLineColumn 0
$tmpdoc documentElement tmproot
set tmpnode [$tmproot selectNodes $toPath]
set line [$tmpnode getLine]
set col [$tmpnode getColumn]
$tmpdoc delete
focus .vs.t
.vs.t mark set insert $line.$col
.vs.t see $line.$col
}
}
}
proc starDOM::UI {} {
variable changed 0 mode "case" query "" info "" root "" style ""
interp alias {} help {} DynamicHelp::register
foreach i {file new open save} {
set im($i) [image create photo \
-file [file join $::BWIDGET::LIBRARY images $i.gif]]
}
frame .f
Button .f.new -image $im(new) -command {starDOM::viewSource Untitled} \
-width 16
help .f.new balloon "Create new XML document
<Control-space> to parse"
Button .f.open -image $im(open) -command {starDOM::openFile .t}
help .f.open balloon "Open existing XML file"
Button .f.view -image $im(file) -width 16 -command starDOM::viewSource
help .f.view balloon "View document source
<Control-space> to reparse after editing"
Button .f.save -image $im(save) -command starDOM::save
help .f.save balloon "Save current document to file"
ComboBox .f.e -width 25 -textvariable starDOM::query
.f.e enable history
.f.e bind <Key> {set starDOM::changed 1}
.f.e bind <Return> {+ starDOM::search .t}
help .f.e balloon "Enter search text/expression here.
Hit <Return> to search (or eval).
History: see pop-up, or use <Up>/<Down>"
ComboBox .f.m -values {
case case/all nocase nocase/all regexp regexp/all XPath XPath/all eval
} -textvariable starDOM::mode
.f.m enable chooser -relief ridge
help .f.m balloon "Search mode (full text, except XPath)
case:\tcase-sensitive
nocase:\tcase-insensitive (A=a)
regexp:\tregular expression
XPath:\tDon't know? Don't bother!
*/all:\tthe same, all at once
eval:\texecute Tcl command (to stdout)"
ComboBox .f.style -values {{} -html -simple} \
-textvariable starDOM::style
.f.style enable chooser -relief ridge
help .f.style balloon "Parsing style:
(blank): regular = strict
-html: tolerant for bad HTML
-simple: fast, 7-bit only"
eval pack [winfo children .f] -side left -fill y
pack .f.e -fill x -expand 1
Tree .t -yscrollcommand ".y set" -xscrollcommand ".x set" -padx 0 \
-opencmd "starDOM::openCross .t" -height 20
bind .t <KeyPress-Right> "starDOM::openCross .t;Tree::_keynav right .t"
.t bindText <1> {.t selection set}
.t bindText <1> {+ starDOM::nodeInfo %W}
.t bindText <Double-1> {starDOM::nodeText %W}
scrollbar .x -ori hori -command ".t xview"
scrollbar .y -ori vert -command ".t yview"
Label .info -textvariable starDOM::info -anchor w -pady 0
help .info balloon "Short info display
3/5: 3rd of 5 instances highlighted
Click on a node for its XPath and #children"
grid .f - -sticky ew
grid .t .y -sticky news
grid .x -sticky news
grid .info - -sticky ew
grid rowconfig . 1 -weight 1
grid columnconfig . 0 -weight 1
if {$::tcl_platform(platform)=="windows"} {
catch {bind .t.c <MouseWheel> {
%W yview scroll [expr {int(pow(%D/-120,3))}] units
}}
catch {focus .t.c}
}
}
#---------------------------------------------------- "main"
starDOM::UI
set starDOM::info "Welcome to starDOM $starDOM::version!"
if {[llength $argv] && [file exists [lindex $argv 0]]} {
starDOM::showTree .t [lindex $argv 0]
} else {
starDOM::showTree .t $starDOM::about 1
}
bind . <Shift-Escape> {console show}
bind . <Escape> {exec wish $argv0 &; exit}
trace variable starDOM::mode w {set starDOM::changed 1 ;#}Alex Caldwell 2002-10-12:This is really nice. I'm going to use it in medical application for a drug database in XML. I added some buttons to the toolbar so I can apply XSL stylesheets using tDOM's xslt command. I then added a button that renders the output from that into a Tkhtml widget. I added some buttons to a frame on the right side of the source view that correspond to the the structure of the XML model for my drug database. This allows entering an XML outline for a new drug rapidly and adding more tags with their data easily. Thanks for all the work. Here's a link to a small package I put together with the modified starDOM.tcl, a few XML drug files and a few early XSL style sheets I'm using. The changes require Tkhtml and IncrTcl to work. http://tkfp.sourceforge.net/starDOM.tar.gz
2002-11-05: (1) RS added Rolf Ade's fix for "xmlns" attribute name
Steve Ball: I wrote a similar megawidget for waX Me Lyrical quite some time ago. It's now available as "domtree" in the TclDOM example directory. See also "domtext" for displaying in a Text widget.
Gary Feng 2003-07-06:It looks like 2 lines in starDOM::showTree should be switched, else it will give a strange error message. It seems it try to find the currently selected node, which has already been deleted. Clearing selection first works for me.
proc starDOM::showTree {w string {isText 0}} {
variable hilited {} root
variable style
raise [winfo toplevel $w]
if {$root != ""} {
[$root ownerDocument] delete
set root "" ;# in case later parsing fails
}
$w selection clear
$w delete [$w nodes root]
