Version 21 of starDOM
Updated 2005-06-07 04:16:21Rolf 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.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
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 10/12/2002 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.
2003-7-6:
Gary Feng: 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]
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, but you can find it here: Another version of the starDOM XML editor
[ A little XML parser | Arts and crafts of Tcl-Tk programming ]