proc xmlToTree src1 {
  # remove comments
  set src [regsub -all <!--{1,1}?.*--> $src1 ""]
  # list of tag index pairs
  set pairs\
    [regexp -inline -indices -all {</?[[:alnum:]]+[^>]*/?>} $src]
  # list of tag strings
  set tagList [lmap pair $pairs {string range $src {*}$pair}]
  # indices of pcdata
  set strIdx [lrange [concat {*}$pairs] 1 end-1]
  # list of pcdata strings
  set strList {}
  foreach {i j} $strIdx {
    lappend strList [string range $src $i+1 $j-1]
  }
  # tokens alternating: tag, pcdata, tag, ...
  set tokens {}
  foreach tag $tagList str $strList {
    lappend tokens $tag
    if {![string is space $str]} then {
      lappend tokens $str
    }
  }
  # process list
  tokensVarToTree tokens
}

proc tokensVarToTree _tokens {
  upvar $_tokens tokens
  set openPattern {<([[:alnum:]:]+)[^>]*>}
  set emptyPattern {<([[:alnum:]:]+)[^>]*/>}
  set closePattern {</([[:alnum:]:]+)>}
  set dataPattern {^[^<]}
  # destructive
  set tokens [lassign $tokens token]
  if {[regexp $dataPattern $token]} then {
    # PCDATA
    dict set result type pcdata
    dict set result content $token
    return $result
  } elseif {[regexp $openPattern $token - name]} then {
    # TAG opening or empty
    dict set result type element
    dict set result name $name
    dict set result attribute {}
    dict set result content ""
    # attributes
    foreach {- key val}\
      [regexp -inline -all {([[:alnum:]]+)="([^"]*)"} $token] {
      dict set result attribute $key $val
    }
    foreach {- key val}\
      [regexp -inline -all {([[:alnum:]]+)='([^']*)'} $token] {
      dict set result attribute $key $val
    }
  }
  if {[regexp $emptyPattern $token]} then {
    # TAG empty: done
    return $result
  }
  while {![regexp $closePattern [lindex $tokens 0]] &&
         [llength $tokens] > 0} {
    # TAG non-empty: fill contents
    dict lappend result content [tokensVarToTree tokens]
  }
  # remove closing TAG 
  set tokens [lrange $tokens 1 end]
  set result
}