sxml.tcl

Linux下的MSN聊天程序源码

		# Remove any elements that were sub-elements	#		
		# of an older element of the same stack level.	#
		#################################################
		foreach oldstent [array names xml_attrs_stack "$cstack:*"] {
		    unset xml_attrs_stack($oldstent)
		    unset xml_data_stack($oldstent)
		}
		set status 2
		set cdata ""
		set xml_attrs_stack($cstack) $ctag_attrs

		#################################################
		# If we have empty_ctag set, then we don't need	#
		# need to search for an end-tag, since it has	#
		# been provived with the trailing /...		#
		#################################################

		if { $empty_ctag } {
		    set status 3
		    set etag "/$tag"
		    continue
		}

		incr c; continue
	    }
	    if { $status == 2 } {
		#################################################
		# 1.8.2						#
		# See if we have the special CDATA start symbol	#
		# at current position, or the end tag...	#
		#################################################

		if { "[string range $cline $c [expr {$c + $xml_s_len}]]" == $xml_cdata_start } {
		    set xml_cdata_parse($id) 1
		    incr c [expr {$xml_s_len + 1}]
		    continue
		}

		if { "[string range $cline $c [expr {$c + $xml_e_len}]]" == $xml_cdata_end } {
		    set xml_cdata_parse($id) 0
		    incr c [expr {$xml_e_len + 1}]
		    continue
		}

		if { $xml_cdata_parse($id) == 1 } {
		    append cdata [xml_handle_bs c $cline $xml_cdata_parse($id)]
		    continue
		}

		#################################################
		# 1.8.2		END OF DATA ALTERATIONS		#
		#################################################

		if { "$ch" == "<" } {
		    set status 3
		    set etag ""
		    if { "$trace" >= 1 } {
			status_log "Trace: Saving $cstack: $cdata"
		    }
		    if {[info exists xml_data_stack($cstack)]} {
			append xml_data_stack($cstack) $cdata
		    } else {
			set xml_data_stack($cstack) $cdata
		    }
		    incr c; continue
		}
		append cdata [xml_handle_bs c $cline $xml_cdata_parse($id)]
		continue
	    }
	    if { $status == 3 } {
		if { "$etag" == "" && "$ch" == "?" } {
		    set status 4
		    set comstart $cfileline
		    set prev_status 2
		    incr c; continue
		}
		if { "$etag" == "" && "$ch" != "/" } {
		    #########################################
		    # We've got an embedded tag     	#
		    # rather than item end tag.     	#
		    #########################################

		    set status 1
		    set tag $ch
		    incr c; continue
		}
		if { "$ch" != ">" } {
		    append etag $ch
		    incr c; continue
		}
		# if { "$ch" == "/" } { }
		#	incr c; continue
		# { }
		#########################################
		# Ok we've got a ">" indicating end of  #
		# deliminator tag, so see if we are	#
		# able to run call back for this	#
		# element.				#
		#########################################
		set etag [string tolower $etag]
		if { "$trace" >= 1 } {
		    status_log "Trace: End-tag: $etag"
		}
		set xx_el [llength [split $cstack :]]
		incr xx_el -1
		set xx_ll [lindex [split $cstack :] $xx_el]
		if { "$etag" != "/$xx_ll" } {
		    if { $xml_attrs(${id}_silent) == 0 } {
			status_log "Error: End tag mismatch ($xx_ll -> $etag)"
			status_log "Current stack: $cstack"
		    }
		    return -3
		}
		set x [lsearch -exact $xml_procs($id) $cstack]
		if { "$trace" >= 2 } {
		    status_log "Trace: Searched $xml_procs($id) for $cstack - Result = $x"
		}
		if { [info exists xml_data_stack($cstack)] } {
		    set cdata "$xml_data_stack($cstack)"
		}
		set xml_data_stack($cstack) "$cdata"
		if { ( $x ==-1 || [expr {$x % 3}] != 0 ) && $xml_attrs(${id}_extended) == 1 } {
		    #################################
		    # If wild carding has been 	#
		    # enabled then perform an extra	#
		    # check...			#
		    #################################
		    set x [do_extended_proc_search $xml_procs($id) $cstack]
		}
		if { $x ==-1 || [expr {$x % 3}] != 0 } {
		    #################################
		    # Check for default handler...	#
		    #################################
		    if { "$defproc" != "" } {
			xml_construct_attr_list $cstack myarr
			xml_construct_data_list $cstack myarr2
			set r [$defproc "$cstack" "$cdata" myarr2 "$xml_attrs_stack($cstack)" myarr $args]
			#########################
			# We need to purge or	#
			# error if required.	#
			#########################
			if { $r == "SXML_PURGE" } {
			    set cdata {}
			    set xml_data_stack($cstack) {}
			} elseif { ($r != "0" && $r != "SXML_OK") || $r == "SXML_ERROR" } {
			    if { $xml_attrs(${id}_silent) == 0 } {
				status_log "Error: Returned error when calling: $defproc"
				status_log "Current stack: $cstack"
			    }
			    return -4
			}
		    } else {
			#################################
			# Since we do not have a tag	#
			# for this element append it to #
			# the saved data....		#
			#################################
			if { "$trace" >= 1 } {
			    status_log "Trace: Added-saved: $tag=$cdata"
			}
		    }
		} else {
		    set proc [lindex $xml_procs($id) [expr {$x + 1}]]
		    if { "$trace" >= 1 } {
			status_log "Trace: Calling proc $proc"
		    }
		    xml_construct_attr_list $cstack myarr
		    xml_construct_data_list $cstack myarr2
		    set r [$proc "$cstack" "$cdata" myarr2 "$xml_attrs_stack($cstack)" myarr]
		    #########################
		    # We need to purge or	#
		    # error if required.	#
		    #########################
		    if { $r == "SXML_PURGE" } {
			set cdata {}
			set xml_data_stack($cstack) {}
		    } elseif { ($r != "0" && $r != "SXML_OK") || $r == "SXML_ERROR" } {
			if { $xml_attrs(${id}_silent) == 0 } {
			    status_log "Error: Returned error when calling: $proc"
			    status_log "Current stack: $cstack"
			}
			return -4
		    }
		}
		set stack_split [split $cstack :]
		set e1 [llength $stack_split]
		incr e1 -2
		set cstack [join [lrange $stack_split 0 $e1] :]
		set cdata ""
		set ctag ""
		set etag ""
		set status 0
		incr c; continue
	    }
	    status_log "stderr: Warning invalid state encountered!"
	    incr c
	}
    }
    if { $status == 4 } {
	if { $xml_attrs(${id}_silent) == 0 } {
	    status_log "Error: End of file during comment - comment started on line $comstart."
	}
	return -5
    }
    if { $status != 0 || [string length $cstack] > 0 } {
	if { $xml_attrs(${id}_silent) == 0 } {
	    status_log "Error: Data exhausted, format not satisfied."
	    status_log "Current stack: $cstack"
	}
	return -6
    }


	if { $xml_attrs(${id}_trace) >= 1 } {
		status_log "sxml $id : Stopped parsing"
	}
    return 0
}

}

proc xml2list xml {
	regsub -all {<\?xml.*\?>} $xml "" xml
	regsub -all {>\s*<} [string trim $xml " \n\t<>"] "\} \{" xml
	set xml [string map {> "\} \{#text \{" < "\}\} \{"}  $xml]
	
	set res ""   ;# string to collect the result
	set stack {} ;# track open tags
	set rest {}
	foreach item "{$xml}" {
		switch -regexp -- $item {
			^# {append res "{[lrange $item 0 end]} " ; #text item}
			^/ {
				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]
				append res "{$tagname [list $rest] {}} "
			}
			default {
				set tagname [lindex $item 0] ;# start tag
				set rest [lrange [string map {= " "} $item] 1 end]
				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 list2xml list {
	switch -- [llength $list] {
		2 {lindex $list 1}
		3 {
			foreach {tag attributes children} $list break
			set res <$tag
			foreach {name value} $attributes {
				append res " $name=\"$value\""
			}
			if [llength $children] {
				append res >
				foreach child $children {
					append res [list2xml $child]
				}
				append res </$tag>
			} else {append res />}
		}
		default {error "could not parse $list"}
	}
}

proc GetXmlEntry { list find {stack ""}} {

	set current_stack $stack
	foreach { entry attributes content} $list {
		set current_stack "$stack:$entry"
		if {$current_stack == $find || $current_stack == ":$find" } {
			#status_log "Found it in $current_stack\n" red
			foreach subkey $content {
				set key [lindex $subkey 0]
				set value [lindex $subkey 1]
				if {$key == "#text" } { 
					#status_log "Found value : $value" blue
					return $value 
				}
			}
			return ""
		} else {
			if {[string first $current_stack $find] == -1 &&
			    [string first $current_stack ":$find"] == -1 } {
				#status_log "$find not in $current_stack" red
				continue
			} else { 
				#status_log "$find is in a subkey of $current_stack\n" red
				foreach subkey $content {
					set result [GetXmlEntry $subkey $find $current_stack]
					if { $result != "" } {
						return $result
					}
				}
			}
		}	
	}
	
	return ""
	
}


proc GetXmlAttribute { list find attribute_name {stack ""}} {

	set current_stack $stack
	foreach { entry attributes content} $list {
		set current_stack "$stack:$entry"
		if {$current_stack == $find || $current_stack == ":$find" } {
			#status_log "Found it in $current_stack\n" blue
			array set attributes_arr $attributes
			if { [info exists attributes_arr($attribute_name)] } {
				return [set attributes_arr($attribute_name)]
			} else {
				return ""
			}
		} else {
			if {[string first $current_stack $find] == -1 &&
			    [string first $current_stack ":$find"] == -1 } {
				#status_log "$find not in $current_stack" red
				continue
			} else { 
				#status_log "$find is in a subkey of $current_stack\n" red
				foreach subkey $content {
					set result [GetXmlAttribute $subkey $find $attribute_name $current_stack]
					if { $result != "" } {
						return $result
					}
				}
			}
		}	
	}
	
	return ""
	
}