sxml.tcl

Linux下的MSN聊天程序源码

#########################################################################
#									#
# Script:	sxml.tcl (namespace sxml)				#
#									#
# Started:	20th October, 2000.					#
#									#
# Completed:	5th November, 2000.					#
#									#
# Author:	Simon Edwards, (C) Proprius Consulting Ltd		#
#									#
# Provides:	sxml namespace (init end register_routine parse)	#
#									#
#		These commands provide an event driven method of	#
#		parsing simple XML files.				#
#									#
# Credits:	Various sources on the web, such as devshed, where	#
#		I've learnt a little about XML.			#
#									#
# Limitations:	This is the initial version - it offers only basic	#
#		parsing functionality, though is good enough, if slow.	#
#									#
# Version:	@(#)0.8.0 Initially released version. (SE)>		#
# 		@(#)0.8.1 Empty element parse error resolved (SE)>	#
# 		@(#)0.8.2 Procedure args, CDATA support (SE)>		#
#									#
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #
#									#
# Version:	0.8.2							#
# Date:		7th August, 2001.					#
# Author:	Simon Edwards, Proprius Consulting Ltd.			#
# Change:	Added support for optional command line arguments to	#
#		pass to a registered routine (Thanks to Jim Garrison 	#
#		([e-mail]).				#
#		Added support for CDATA attributes meaning that these	#
#		routines can handle "binary" data.			#
#		It expects the start of the block to have the following	#
#		definition:						#
#									#
#		<![CDATA[						#
#		At the end of the block the following definition is	#
#		expected:						#
#									#
#		]]>							#
#									#
#		If you need to include that sequence of characters in	#
#		the data then the following should be used instead:	#
#									#
#		]]&gt;							#
#									#
#		WARNING:	The details between the deliminators	#
#				for CDATA mean that EVERY BYTE is 	#
#				including in the element. This 		#
#				is as the XML specification (at least	#
#				as far as my basic understanding).	#
#									#
#		Support has also been added for the set_attr function	#
#		which is an interface to be able to set various 	#
#		functions which will affect the parsing of files.	#
#		The attributes are particular to each file to parse	#
#		and need to be set using the parse descriptor for a	#
#		particular file. All attributes are given suitable 	#
#		defaults.						#
#									#
#		Attribute	Values	Purpose				#
#		=========	======	=============================== #
#		trace		0/1/2	Whether to show trace info	#
#					when parsing a particular file.	#
#					Default is 0 (no).		#
#					2 Is the highest level of trace	#
#					whilst 1 gives more details 	#
#					than most people want anyway!	#
#		silent		0/1	Whether or not any errors 	#
#					found during the parse are sent	#
#					to the "stderr" channel. 	#
#					default is 0 (show errors).	#
#		pedantic	0/1	Whether to check when a proc is	#
#					registered whether it actually	#
#					exists and has the correct	#
#					number of arguments. Default is	#
#					0 (not pedantic).		#
#		extended	0/1	If set to 1 will look to see if	#
#					a event has been registered for	#
#					a "wildcard" at the latest	#
#					level of a element. Slower, but	#
#					allows improved parsing. Default#
#					is 0.				#
#									#
# Version:	0.8.1							#
# Date:		26th November, 2000.					#
# Author:	Simon Edwards, Proprius Consulting Ltd.			#
# Change:	Corrected assumption that an empty element tag		#
#		cannot have attributes, so now correctly handles	#
#		cases such as:						#
#		<testelement name="fred"/>				#
#									#
#########################################################################

###############################################################################
#    sxml.tcl - tcl module to provide basis XML parsing			      #
#    Copyright (C) 2000-2001 Simon Edwards, Proprius Consulting Ltd           #
#                                                                             #
#    This program is free software; you can redistribute it and/or modify     #
#    it under the terms of the GNU General Public License as published by     #
#    the Free Software Foundation; either version 2 of the License, or        #
#    (at your option) any later version.                                      #
#                                                                             #
#    This program is distributed in the hope that it will be useful,          #
#    but WITHOUT ANY WARRANTY; without even the implied warranty of           #
#    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the            #
#    GNU General Public License for more details.                             #
#                                                                             #
#    You should have received a copy of the GNU General Public License        #
#    along with this program; if not, write to the Free Software              #
#    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA  #
#                                                                             #
#    If you wish to contact the author the following details can be used;     #
#                                                                             #
#    [e-mail]                                             #
###############################################################################

namespace eval sxml {

    namespace export init end register_routine parse set_attr puts

    if { $initialize_amsn == 1 } {
	variable xml_invoc
	variable xml_stack
	variable xml_file
	variable xml_procs
	variable xml_hadtoplevel
	variable xml_cdata_parse
	variable xml_cdata_start
	variable xml_cdata_end
	variable xml_cdata_sub
	variable xml_attrs
	
	set xml_cdata_start {<![CDATA[}
	set xml_cdata_end {]]>}
	set xml_invoc 0
    }

	 #Added by Alvaro Iradier. Use this instead of putting directly to the file, to
	 #replace special characters
	 proc xmlreplace {string} {
	 	return [string map { "<" "&lt;" ">" "&gt;" "&" "&amp;" "\"" "&quot;" "'" "&apos;"} $string]
	 }

	 proc replacexml {string} {
	 	return [string map { "&lt;" "<" "&gt;" ">" "&amp;" "&" "&quot;" "\"" "&apos;" "'" } $string]
	 }

    proc init {file} {
	variable xml_invoc
	variable xml_stack
	variable xml_file
	variable xml_procs
	variable xml_attrs_stack
	variable xml_hadtoplevel
	variable xml_cdata_parse
	variable xml_attrs

	if { [catch {set fd [open $file]}]  } {
	    return -1
	}
	
	fconfigure $fd -encoding utf-8

	incr xml_invoc
	set xml_cdata_parse($xml_invoc) 0
	set xml_stack($xml_invoc) {}
	set xml_procs($xml_invoc) {}
	set xml_file($xml_invoc) $fd
	set xml_hadtoplevel($xml_invoc) 0

	#################################################################
	# Default the attributes currently supported.			#
	#################################################################
	set xml_attrs(${xml_invoc}_trace) 0
	set xml_attrs(${xml_invoc}_silent) 0
	set xml_attrs(${xml_invoc}_pedantic) 0
	set xml_attrs(${xml_invoc}_extended) 0

	return $xml_invoc
    }

    proc set_attr {id attr val} {
	variable xml_attrs
	variable xml_stack

	if { ! [info exists xml_stack(${id})] } {
	    return -1
	}
	if { ! [info exists xml_attrs(${id}_$attr)] } {
	    return -2
	}
	set xml_attrs(${id}_$attr) $val
	return 0
    }

    proc end {id} {
	variable xml_stack
	variable xml_file
	variable xml_procs
	variable xml_attrs_stack
	variable xml_cdata_parse
	variable xml_attrs

	if { ! [info exists xml_stack($id)] } {
	    return -1
	}


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

	catch {close $xml_file($id)}
	unset xml_file($id)
	unset xml_stack($id)
	unset xml_procs($id)
	unset xml_cdata_parse($id)

	unset xml_attrs(${id}_trace)
	unset xml_attrs(${id}_silent)
	unset xml_attrs(${id}_pedantic)
	unset xml_attrs(${id}_extended)
	return 0
    }

    #########################################################################
    # Construct an array containing all attributes details for all          #
    # sub-elements in the current stack.                                    #
    #########################################################################

    proc xml_construct_attr_list {stack myarr} {
	variable xml_attrs_stack
	upvar $myarr xx

	catch {unset xx}
	set xx(_dummy_) ""
	if { ! [info exists xml_attrs_stack] } {
	    return 0
	}

	foreach xxx [array names xml_attrs_stack "$stack:*"] {
	    set xx($xxx) $xml_attrs_stack($xxx)
	}
	return 0
    }

    proc xml_construct_data_list {stack myarr} {
	variable xml_data_stack
	upvar $myarr xx

	catch {unset xx}
	set xx(_dummy_) ""

	if { ! [info exists xml_data_stack]} {
	    return
	}
	foreach xxx [array names xml_data_stack "$stack:*"] {
	    set xx($xxx) $xml_data_stack($xxx)
	}
    }

    proc register_routine {id path proc args} {
	variable xml_stack
	variable xml_procs
	variable xml_attrs

	if { ! [info exists xml_stack($id)]} {
	    return -1
	}

	#################################################################
	# We should also make sure that the specified routine already	#
	# exists, and has the correct number of arguments.		#
	# But only if pedantic has been turned on...			#
	#################################################################

	if { $xml_attrs(${id}_pedantic) == 1 } {
	    set valid [info procs $proc]
	    if { "$valid" == "" } {
		if { $xml_attrs(${id}_silent) == 0 } {
		    status_log "Error: Specified procedure to register \"$proc\" is not defined."
		}
		return -2
	    }
	    set args [info args $proc]
	    if { [llength $args] != 6 } {
		if { $xml_attrs(${id}_silent) == 0 } {
		    status_log "Error: Specified procedure to register \"$proc\" does not have valid argument count."
		}
		return -3
	    }
	}

	set path [string tolower $path]
	set x [lsearch -exact $xml_procs($id) $path]
	if { $x !=-1 } {
	    set xml_procs($id) [lreplace $xml_procs($id) $x [expr {$x + 1}] $path $proc]
	    return 0
	}

	lappend xml_procs($id) $path $proc $args
	return 0
    }

    proc xml_tag_attrs_to_str {attrstr empty_t incdata} {
	upvar $empty_t empty_tag

	set empty_tag 0
	set oattr $attrstr
	set attrs {}
	set x 1
	while {1} {
	    set x [regexp { ([[:alnum:]\-_]+)="([^"]*)"} $attrstr junk a1 a2]
		if {$x == 0} break
		if { ! [validate_name $a1] } {
			status_log "Error: Invalid attribute name: $a1"
			return -code error 1
		}
		set a2 [xml_handle_bs_string $a2 $incdata]
		lappend attrs $a1 $a2
		regsub {([[:alnum:]\-_]+)="([^"]*)"} $attrstr {} xx
					    set attrstr $xx
					}

	    if { "[string trim "$attrstr"]" == "/" } {
		set empty_tag 1
	    } elseif {[llength $attrstr] != 0} {
		status_log "Malformed attributes: $attrstr found in:\n$oattr"
		return -code error 1
	    }
	    return $attrs
	}

	#########################################################################
	# The function below is used to valid the format of attribute and	#
	# element names. These must begin with a letter or underscore and	#
	# can consist of letters, underscore, dash and numbers only.		#
	# Will return 1 if name is valid, 0 otherwise.				#
	#########################################################################

	proc validate_name {n} {
	    set x [regexp {^[_\-[:alpha:]][_\-[:alnum:]]*} $n matched]
	    if { $x == 0 } {
		return 0
	    }
	    if { "$matched" == "$n" } {