Tcl parsing xml test description file

#This script is using xml to define testcases and testsuite. With this, it is very easier to create new testcases, without need to update the script framework;
#Testunit would be the basic unit in the xml, which corresponding to a proc in tcl script, as the function block, such as make connection, iperf traffic test, set/get MIB etc;
#A testcases.xml is a predefined testcase set, which only need to be updated when a new test scenario is needed;
#Each testcase contains one or more testunit, plus setting and expect result as attr;
#Testsuite xml is user defined collection of testcases and testunits;

#Each xml must have one and only one root tag, and struct like this:
# <root_tag attr1=xxx attr2=yyy ...>
#     text
#     <sub_tag1 sub_tag1_attr1 ...>
#     <sub_tag2 sub_tag2_attr1 ...>

#In topologic, each tag is a node, attr is a list, and sub tags are sub nodes;

#http://wiki.tcl.tk/1740 convert content to xml format, default tag is 'document'
proc asXML {content {tag document}} {
    set XML_MAP {
        < &lt;
        > &gt;
        & &amp;
        \" &quot;
        ' &apos;
    }
    return <$tag>[string map $XML_MAP $content]</$tag>
}

#http://wiki.tcl.tk/3919 A little XML parser
#convert xml to: tag {list: attr} {list: #text {_text_}, subTag1, subTag2 ...}
proc xml2list xml {
    # trim only deal with the begin and end of the whole xml
    #puts "dbg trim: \[[string trim $xml " \n\t<>"]\]"
    regsub -all {>\s*<} [string trim $xml " \n\t<>"] "\} \{" xml
    # above regsub replace '>' and '<' with brace if no text between them. It also remove \r \n between '>' and '<'
    #puts "dbg after regsub: \[$xml\]"
    set xml [string map {> "\} \{#text \{" < "\}\} \{"}  $xml]
    #puts "dbg after map: \[$xml\]"
   
    set res ""   ;# string to collect the result  
    set stack {} ;# track open tags
    set rest {}
    foreach item "{$xml}" {
        #puts "dbg item => $item"
        switch -regexp -- $item {
            ^# {append res "{$item} " ; #text item, or "{#text [lrange $item 1 end]} ", origin post not work as it said: "{[lrange $item 0 end]} "}
            ^/ {
                regexp {/(.+)} $item -> tagname ;# end tag
                set expected [lindex $stack end]
                if {$tagname!=$expected} {error "$item != $expected"}
                set stack [lrange $stack 0 end-1]
                append res "\}\} "
            }
            /$ { # singleton - start and end in one <> group
                regexp {([^ ]+)( (.+))?/$} $item -> tagname - rest
               #set rest [lrange [string map {= " "} $rest] 0 end] <= not work if attribute like: attr1="var=x"
                regsub -all {=\s*"} $rest " \"" rest
                regsub -all {=\s*'} $rest " '" rest
                set rest [lrange $rest 0 end]
               #with above two lines, attribute has to be single/double quoted
                append res "{$tagname [list $rest] {}} "
            }
            default {
                set tagname [lindex $item 0] ;# start tag
               #set rest [lrange [string map {= " "} $item] 1 end] <= same as above, not work if attribute contains equal
                regsub -all {=\s*"} $item " \"" item
                regsub -all {=\s*'} $item " '" item
                set rest [lrange $item 1 end]
               #with above two lines, attribute value has to be single/double quoted, but the value should not contain such as ="
                lappend stack $tagname
                append res "\{$tagname [list $rest] \{"
            }
        }
        if {[llength $rest]%2} {error "att's not paired: $rest"}
    }
    if [llength $stack] {error "unresolved: $stack"}
    string map {"\} \}" "\}\}"} [lindex $res 0]
}

proc xputs {msg {log 0}} {
    variable xputs_level
    set indent ""
    if {[info exists xputs_level] && [regexp {^\d+$} $xputs_level]} {set indent [string repeat {  } $xputs_level]}
    if {$log ne "0"} {send_user "$indent$msg\n"
    } else {puts "$indent$msg"}
}

proc print_tree {lxml level} {
    #puts "level = $level"
    puts "[string repeat {  } $level]tag = [lindex $lxml 0]"
    puts "[string repeat {  } $level]att = [lindex $lxml 1]"
    incr level
    foreach sitem [lindex $lxml 2] {
        print_tree $sitem $level
    }
}

#testcases.xml is xml file contains pre-defined testcases. This xml file would be processed to generate an array of testcases definition, no execution here
#testcase name is the index of the array, such as 'TC-SCAN-3-1', and each element of the array defines how to run the testcase, include setting, expect result, and testunit needs to be executed
#the analyze result will be set in variable testcases which is an array;
#Each testcase must have at least one TU, and setting/exp_res passed to the TU/TUs as arguments
#The test xml such as a Test Suite may have one or more testcases. All testcases within one xml node shares all settings, such as repeat counter, timeout setting
#Within one xml node, may have multiple setting, the later setting will be appended, override old value, but no reset. Setting won't be passed to sibling nodes
#Setting would be passed to direct child as reference, where a setting/expect node will update them, and a TC/TU node will take it as input args
#TODO: Currently setting won't be passed cross a node. Setting inherit more than parent? Setting per testcase? Good side: avoid pollution. Bad: cannot share       

proc process_testcases_xml {tc_xml_file} {
    variable testcases
    variable tc_subs    ;#for subs defined in testcases_xml
    set fp [open $tc_xml_file]
    set testcases_xml [read $fp]
    close $fp
   
    #puts "Original xml:\n$testcases_xml"
    set l_tcs_xml [xml2list [regsub -all {(^|\n)\s*#[^\n]*\n} $testcases_xml {\1}]] ;#remove comment and covert xml to list
    set tc_sub_list {}
    #puts "tcs xml list: $l_tcs_xml"
    #print_tree $l_tcs_xml 0
    set ltcs [lindex $l_tcs_xml 2]
    foreach tc $ltcs {
        #puts "=>$tc"
        #=>testcase {name TC-SCAN-3-1} {{setting {Operation Link, Chan 1, Mask 1, Repeat 4} {}} {expect {result success} {}} {run {name TU_scan_test} {}}}
        if {[lindex $tc 0] eq "sub"} {
            set tc_subs([lindex [lindex $tc 1] 1]) $tc
        } else {set testcases([lindex [lindex $tc 1] 1]) [lindex $tc 2]}
    }
    #puts "\n _dbg_: dump tc_subs:" ; foreach {key value} [array get tc_subs] {puts "  $key => $value"}
}

proc get_sub_xlst {lxml sub_name} {
    set found false
    if {[lindex $lxml 0] eq "sub"} {
        array set attrs [lindex $lxml 1]
        if {[info exists attrs(name)] && $attrs(name) eq $sub_name} {return $lxml}
    }
    foreach sitem [lindex $lxml 2] {
        set found [get_sub_xlst $sitem $sub_name]
        if {$found ne "false"} {return $found}
    }
    return $found
}

#xlst is a three elments list of a xml node: node_tag, list of attrs, list of sub_node; param level is for debug purpose
#p_setting and p_exp_res is parent setting and exp_res, for current node and current node's sibling nodes
#No inherit of setting and exp_res as that would be messy, error prone and complex. So here allow to pass optional setting as attr of TC.
#Note: there is two ways to run a TC testcase, either use 'run TC-xxx' to start a predefined TC, or have a tag's name started with "TC-"
#Add global AbortTC to abort all testcases whenever needed. Not abort TU as user may still want to do TU_TEST to dump data
set AbortTC no
proc process_xmlnode {xlst level {p_setting ""} {p_exp_res ""}} {
    variable testcases
    variable tc_subs
    variable xputs_level
    variable full_tree  ;#for processing 'use'
       
    set node  [lindex $xlst 0]
    set attrs [lindex $xlst 1]
    #index 1 in xlst is key-value paired list and 1st pair should be a testunit or testcase name like TU-SETUP-HOSTS or TC-TRAFFIC-10
    #other attr could be optional setting of the testcase, or override the TC setting, may also set like expected result
    #convert attrs as array as it is key-value pairs
    set subnodes [lindex $xlst 2]
    set xputs_level $level
    upvar $p_setting cur_setting $p_exp_res cur_exp_res
    #setting and exp_res for sub nodes
    set s_setting ""
    set s_exp_res ""
   
    #inherit parent setting/exp_res: 1st, it doesn't work; 2nd, it is a bad approach as explained above.
    #set s_setting $p_setting
    #set s_exp_res $p_exp_res
   
    #xputs "Level $level node is <$node> with attr list: ($attrs)"
    #TODO: decide what to do with the $attrs
   
    if {$node eq "setting"} {
        #put setting in upvar variable as it is for parent node, and only need to perform setting in one shot(TU-SETUP-HOSTS?) to make it more effient
        set cur_setting [dict merge $cur_setting $attrs]
        if {$::LOG_LEVEL>2} {xputs " A setting: $attrs"}
    } elseif {$node eq "expect"} {
        #put expect to an upvar variable as it is for parent node and it will be checked in testunit of the parent node
        set cur_exp_res [dict merge $cur_exp_res $attrs]
        if {$::LOG_LEVEL>2} {xputs " An expect: $attrs"}
    } elseif {$node eq "exec"} {
        #print a message, eval tcl; be careful as support is limited, due to nature of xml and tcl, as quote, slash and many special character will cause issue
        #Note $attrs is treated as dict, so duplicate key in $attrs will get lost
        #Also, for eval, set variable without uplevel will get lost as this is a recursive call of process_xmlnode
        #For exec an external/system command, too many hassle: not sure the cwd, nowhere capture the output; Use eval if needed like this: <exec eval="puts [exec date]" />
        if {$::LOG_LEVEL>2} {xputs " An exec request: $attrs"}
        dict for {op args} $attrs {
            switch -exact -- $op {
               "echo" {puts $args}
               "eval" {eval $args}
               default {puts stderr "Unsupported operation: $op"}
            }
        }
    } elseif {$node eq "run"} {
        array set run_setting $attrs
        if {[info exists run_setting(name)]} {
            if {[regexp {^TC} $run_setting(name)]} {
                variable tc_results
                variable cur_tc_result
                variable tc_idx
                variable TC_name
                variable f_csv
                               
                set TC_name $run_setting(name)
                set cur_tc_result ""
                #setting for testcase are ignored for now. Should be repeat number, timeout etc.
                #upvar $setting cur_setting
                puts ""
                xputs " <Run testcase $TC_name" 1
                if {[info exists f_csv]} {puts $f_csv "Run testcase $TC_name"}
                if {$::AbortTC} {
                    set cur_tc_result "Aborted"
                    xputs "  $cur_tc_result" 1
                } else {
                    #pick the optional setting from TC attr
                    set s_setting [dict remove $attrs name]
                    foreach subnode $testcases($TC_name) {process_xmlnode $subnode [expr $level+1] s_setting s_exp_res}
                }
                dict set tc_results $TC_name $cur_tc_result
                incr tc_idx
            } elseif {[regexp {^TU} $run_setting(name)]} {
                if {$::LOG_LEVEL>1} {xputs " <Run testunit $run_setting(name)" 1}
                if {[catch {_$run_setting(name) $cur_setting $cur_exp_res} ret_code]} {
                    send_user "\n\n**** Exception while running $run_setting(name) ****\n$ret_code\n**** Full error info:\n$::errorInfo\n****\n"
                    #log_stacktrace ;# too many as this is inside recursive call
                }
            }
        } else {xputs "\t## no-name run with attrs: [array get attrs]"}
    } elseif {$node eq "use"} { ;#no attrs, neither sub-nodes expected with use
        array set use_setting $attrs
        if {[info exists use_setting(name)]} {
            set sub_name $use_setting(name)
            set use_xlst [get_sub_xlst $full_tree $sub_name]  ;#search instead of create sub list on fly, so the sub can be declared after the place invoke it
            if {$use_xlst eq "false" && [info exists tc_subs($sub_name)]} {set use_xlst $tc_subs($sub_name)}
            if {$use_xlst eq "false"} {
                xputs "\t## Not found $sub_name for use. Ignored!"
                puts "\n _dbg_: existing tc_subs:" ; foreach {key value} [array get tc_subs] {puts "  $key => $value"}
            } else {
                #puts "*process use: $use_xlst, s=$cur_setting, e=$cur_exp_res"
                #process_xmlnode $use_xlst $level cur_setting cur_exp_res
                #used node is a container, will ignore the attrs, and directly process subnodes of it
                foreach subnode [lindex $use_xlst 2] {process_xmlnode $subnode $level cur_setting cur_exp_res}
            }
        } else {xputs "\t## Missing tag for use, useless attrs: [array get attrs]"}
    } elseif {$node eq "sub"} { ;#sub block which will be invoked by others. so no processing here. Will search the list when needed
    } else {
        variable TC_name
        variable tc_results
        variable cur_tc_result
        variable tc_idx
        set is_TC no
        if {[regexp -- {(TC-\S+)} $node -> TC_name]} {
            send_user "\n\n<$TC_name>\n"
            set is_TC yes
            set cur_tc_result ""
        }
        #only node other than 'setting', 'expect' and 'run' may have sub-nodes
        foreach subnode $subnodes {process_xmlnode $subnode [expr $level+1] s_setting s_exp_res}
        if {$is_TC} {
            dict set tc_results $TC_name $cur_tc_result
            incr tc_idx
        }   
    }
}

proc process_test_xml {xml_file {tc_xml_file ""}} {
    variable testcases
    variable full_tree
    variable f_csv

    if {[info exists f_csv]} {set create_local_mon_log no
    } else {
        set create_local_mon_log yes
        set f_csv [open monitor.log w]
    }
    #first, process predefined testcases in $tc_xml_file
    if {$tc_xml_file eq ""} {
        if {[regexp {([^@]+)@([^@]+)} $xml_file -> xml_file tc_xml_file]==0} {set tc_xml_file $::XML_ROOT_DIR/testcases.xml}
    }
    process_testcases_xml $tc_xml_file
    #foreach {tc_name tc_setting} [array get testcases] {puts "$tc_name => $tc_setting"}
   
    #start processing xml_file
    set fp [open $xml_file]
    set test_xml [read $fp]
    close $fp
   
    #below regsub is for filtering out comment line in XML which is start with '#' as the 1st non-space character of a line, which is not conforming to the XML standard. May be removed in future
    regsub -all {(^|\n)\s*#[^\n]*\n} $test_xml {\1} test_xml
   
    set full_tree [xml2list $test_xml]
    #print_tree $full_tree 0
    variable tc_results
    variable tc_idx 0
    process_xmlnode $full_tree 0
   
    if {$create_local_mon_log} {close $f_csv}
}