• Some work on the generated dialogue is needed (if you edit "DATA", you may want to have a proper text widget, not an entry widget at your disposal)
• Checks are required to avoid inadvertent loss of work
• Add the Gtk look for use on Linux/UNIX

Code  edit

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.43
    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>Arjen Markus</author>
            <author>Richard Suchenwirth</author>
          </authors>
        </about>"

     namespace eval vars {
         # Private variables, when editing attributes
         variable save_node ""
     }
}
#------------------------------------------ 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::formatNodeText {node} {
    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"
        }
    }
    return $text
}
proc starDOM::insertNode {w parent node} {
    set drawcross "auto"
    set fill "black"
    set text [formatNodeText $node]
    switch [$node nodeType] {
        "ELEMENT_NODE" {
            set children [$node childNodes]
            if {[llength $children]!=1 || [$children nodeName]=="#text"} {
                set drawcross "allways" ;# bad English, wanted by BWidget
            }
        }
        "COMMENT_NODE" -
        "PROCESSING_INSTRUCTION_NODE" {
            set fill "grey50"
        }
        default {
            set fill "black"
        }
    }
    $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::nodeText {w node} {
     if { $vars::save_node != "" } {
         raise .tnode
         return
     }

     set vars::save_node    $node

     $w itemconfigure $node -fill red

     set tag      [$node nodeName]

     #
     # Now create a toplevel window to edit the attribute values
     #
     toplevel .tnode
     frame    .tnode.f
     wm title .tnode "Attributes for: $tag"

     foreach att [$node attributes] {
         if {[llength $att] == 3} { #(1)..
             if {[lindex $att 2] == {}} {
                 set attrib "xmlns"
                 if {[lindex $att 1] != {}} {
                     append attrib ":[lindex $att 1]"
                 }
             } else {
                 set attrib "[lindex $att 1]:[lindex $att 0]"
             }
         } else {
             set attrib $att
         } ;#..(1)

         set vars::$attrib [$node getAttribute $attrib]
         label .tnode.f.l$attrib -text $attrib
         entry .tnode.f.e$attrib -textvariable ::starDOM::vars::$attrib
         grid  .tnode.f.l$attrib .tnode.f.e$attrib \
             -sticky nw -padx 3 -pady 2
     }

     set children [$node childNodes]
     if {[llength $children]==1 && [$children nodeName]=="#text"} {
        label .tnode.f.l_data -text "DATA:"
        entry .tnode.f.e_data -textvariable ::starDOM::vars::DATA
        grid  .tnode.f.l_data .tnode.f.e_data \
            -sticky nw -padx 3 -pady 2
        set vars::DATA [$children nodeValue]
     }

     button .tnode.ok     -text OK     \
         -command [list starDOM::closeNodeEdit $w 1] -width 6
     button .tnode.cancel -text Cancel \
         -command [list starDOM::closeNodeEdit $w 0] -width 6

     grid   .tnode.f -
     grid   .tnode.ok .tnode.cancel -padx 3 -pady 4
}
proc starDOM::closeNodeEdit {w save} {
    if { $save } {
        foreach att [$vars::save_node attributes] {
            if {[llength $att] == 3} { #(1)..
                if {[lindex $att 2] == {}} {
                    set attrib "xmlns"
                    if {[lindex $att 1] != {}} {
                        append attrib ":[lindex $att 1]"
                    }
                } else {
                    set attrib "[lindex $att 1]:[lindex $att 0]"
                }
            } else {
                set attrib $att
            } ;#..(1)
            $vars::save_node setAttribute $attrib [set vars::$attrib]
        }
        set children [$vars::save_node childNodes]
        if {[llength $children]==1 && [$children nodeName]=="#text"} {
           $children nodeValue [set vars::DATA]
        }
        # .t needed directly - $w is the canvas!
        .t itemconfigure $vars::save_node -text \
            [formatNodeText $vars::save_node]
    }

    destroy .tnode
    $w itemconfigure $vars::save_node -fill black
    set vars::save_node ""
}
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::viewAbout {} {
    tk_messageBox -icon info -title starDOM -type ok -message \
tarDOM:
simple XML file viewer/editor
Rolf Ade, Arjen Markus, and
chard Suchenwirth}
    destroy .vs
}
proc starDOM::closeWindow {} {
    # TODO: check if the contents have changed
    destroy .vs
}
proc starDOM::exitGUI {} {
    # TODO: check if this is really what the user wants
    destroy .
}
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"

    #
    # Set up the (simple) menu bar
    set  mw    .vs.menu
    menu       $mw
    menu       $mw.window  -tearoff false

    $mw add cascade -label Window -menu $mw.window

    .vs configure -menu $mw

    #
    # Set up the "Window" menu
    #
    $mw.window add command -label Save -underline 0 \
       -command {starDOM::showTree .t [.vs.t get 1.0 end] 1}
    $mw.window add separator
    $mw.window add command -label Close -underline 0 \
       -command {starDOM::closeWindow}

    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]]
    }

    #
    # Set up the (simple) menu bar
    set  mw    .menu
    menu       $mw
    menu       $mw.file  -tearoff false
    menu       $mw.edit  -tearoff false
    menu       $mw.help  -tearoff false

    $mw add cascade -label File   -menu $mw.file
    $mw add cascade -label Edit   -menu $mw.edit
    $mw add cascade -label Help   -menu $mw.help

    . configure -menu $mw

    #
    # Set up the "File" menu
    #
    $mw.file add command -label New -underline 0 \
        -command {starDOM::viewSource Untitled}
    $mw.file add command -label Open -underline 0 \
       -command {starDOM::openFile .t}
    $mw.file add separator
   # $mw.file add command -label Save -underline 0 \
   #    -command {starDOM::save}
     $mw.file add command -label "Save as ..." -underline 1 \
        -command {starDOM::save}
    $mw.file add separator
    $mw.file add command -label Exit -underline 1 \
       -command {starDOM::exitGUI}

    $mw.edit add command -label "Edit source" -underline 1 \
        -command {starDOM::viewSource}

    $mw.help add command -label "About ..." -underline 0 \
        -command {starDOM::viewAbout}

    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 ;#}

--- stardom1.tcl        Thu Sep 30 06:27:31 2004
+++ stardom2.tcl        Thu Sep 30 07:19:28 2004
@@ -79,7 +79,7 @@
        if {[string length $res]>70} {set res [string range $res 0 69]...}
        set info $res
     }
-    proc starDOM::formatNodeText {node} {
+    proc starDOM::formatNodeText {node {isopen 0}} {
        switch [$node nodeType] {
            "ELEMENT_NODE" {
                set text "<[$node nodeName]"
@@ -102,7 +102,10 @@
                if {[$node hasChildNodes]} {
                    set children [$node childNodes]
                    if {[llength $children]==1 && [$children nodeName]=="#text"} {
-                       append text [string map {\n " "} [$children nodeValue]]
+                       #show #text to right of closed node only
+                       if {!$isopen} {
+                           append text [string map {\n " "} [$children nodeValue]]
+                       }
                    } else {
                        set drawcross "allways" ;# bad English, wanted by BWidget
                    }
@@ -236,10 +239,14 @@
            set children [$vars::save_node childNodes]
            if {[llength $children]==1 && [$children nodeName]=="#text"} {
               $children nodeValue [set vars::DATA]
+                  if {[llength [.t nodes $vars::save_node]]} {
+                  .t itemconfigure [.t nodes $vars::save_node 0] -text [set vars::DATA]
+              }
            }
           # .t needed directly - $w is the canvas!
+             set isopen [.t itemcget $vars::save_node -open]
            .t itemconfigure $vars::save_node -text \
-               [formatNodeText $vars::save_node]
+               [formatNodeText $vars::save_node $isopen]
        }
        destroy .tnode
@@ -254,6 +261,11 @@
            }
            $w itemconfigure $node -drawcross "auto"
        }
+      .t itemconfigure $node -text [formatNodeText $node 1]
+    }
+    proc starDOM::closeCross {w {node ""}} {
+       if {$node == ""} {set node [$w selection get]}
+       .t itemconfigure $node -text [formatNodeText $node]
     }
     proc starDOM::openFile {w {filename ""}} {
        variable info
@@ -533,7 +545,7 @@
        pack  .f.e -fill x -expand 1
        Tree .t -yscrollcommand ".y set" -xscrollcommand ".x set" -padx 0 \
-               -opencmd "starDOM::openCross .t" -height 20
+               -opencmd "starDOM::openCross .t" -closecmd "starDOM::closeCross .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}

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• Previous page
• Next page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References