tclparser-8.1.tcl

来自「Linux下的MSN聊天程序源码」· TCL 代码 · 共 613 行 · 第 1/2 页

# tclparser-8.1.tcl --
#
#	This file provides a Tcl implementation of a XML parser.
#	This file supports Tcl 8.1.
#
#	See xml-8.[01].tcl for definitions of character sets and
#	regular expressions.
#
# Copyright (c) 1998-2003 Zveno Pty Ltd
# http://www.zveno.com/
# 
# See the file "LICENSE" in this distribution for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# $Id: tclparser-8.1.tcl 5915 2006-01-23 12:43:37Z tjikkun $

package require Tcl 8.1

package provide xml::tclparser 3.1

package require xmldefs 3.1

package require sgmlparser 1.0

namespace eval xml::tclparser {

    namespace export create createexternal externalentity parse configure get delete

    # Tokenising expressions

    variable tokExpr $::xml::tokExpr
    variable substExpr $::xml::substExpr

    # Register this parser class

    ::xml::parserclass create tcl \
	    -createcommand [namespace code create] \
	    -createentityparsercommand [namespace code createentityparser] \
	    -parsecommand [namespace code parse] \
	    -configurecommand [namespace code configure] \
	    -deletecommand [namespace code delete] \
	    -resetcommand [namespace code reset]
}

# xml::tclparser::create --
#
#	Creates XML parser object.
#
# Arguments:
#	name	unique identifier for this instance
#
# Results:
#	The state variable is initialised.

proc xml::tclparser::create name {

    # Initialise state variable
    upvar \#0 [namespace current]::$name parser
    array set parser [list -name $name			\
	-cmd [uplevel 3 namespace current]::$name	\
	-final 1					\
	-validate 0					\
	-statevariable [namespace current]::$name	\
	-baseuri {}					\
	internaldtd {}					\
	entities [namespace current]::Entities$name	\
	extentities [namespace current]::ExtEntities$name	\
	parameterentities [namespace current]::PEntities$name	\
	externalparameterentities [namespace current]::ExtPEntities$name	\
	elementdecls [namespace current]::ElDecls$name	\
	attlistdecls [namespace current]::AttlistDecls$name	\
	notationdecls [namespace current]::NotDecls$name	\
	depth 0						\
	leftover {}                                     \
    ]

    # Initialise entities with predefined set
    array set [namespace current]::Entities$name [array get ::sgml::EntityPredef]

    return $parser(-cmd)
}

# xml::tclparser::createentityparser --
#
#	Creates XML parser object for an entity.
#
# Arguments:
#	name	name for the new parser
#	parent	name of parent parser
#
# Results:
#	The state variable is initialised.

proc xml::tclparser::createentityparser {parent name} {
    upvar #0 [namespace current]::$parent p

    # Initialise state variable
    upvar \#0 [namespace current]::$name external
    array set external [array get p]

    regsub $parent $p(-cmd) {} parentns

    array set external [list -name $name		\
	-cmd $parentns$name				\
	-statevariable [namespace current]::$name	\
	internaldtd {}					\
	line 0						\
    ]
    incr external(depth)

    return $external(-cmd)
}

# xml::tclparser::configure --
#
#	Configures a XML parser object.
#
# Arguments:
#	name	unique identifier for this instance
#	args	option name/value pairs
#
# Results:
#	May change values of config options

proc xml::tclparser::configure {name args} {
    upvar \#0 [namespace current]::$name parser

    # BUG: very crude, no checks for illegal args
    # Mats: Should be synced with sgmlparser.tcl
    set options {-elementstartcommand -elementendcommand \
      -characterdatacommand -processinginstructioncommand \
      -externalentitycommand -xmldeclcommand \
      -doctypecommand -commentcommand \
      -entitydeclcommand -unparsedentitydeclcommand \
      -parameterentitydeclcommand -notationdeclcommand \
      -elementdeclcommand -attlistdeclcommand \
      -paramentityparsing -defaultexpandinternalentities \
      -startdoctypedeclcommand -enddoctypedeclcommand \
      -entityreferencecommand -warningcommand \
      -defaultcommand -unknownencodingcommand -notstandalonecommand \
      -startcdatasectioncommand -endcdatasectioncommand \
      -errorcommand -final \
      -validate -baseuri -baseurl \
      -name -cmd -emptyelement \
      -parseattributelistcommand -parseentitydeclcommand \
      -normalize -internaldtd -dtdsubset \
      -reportempty -ignorewhitespace \
      -reportempty \
    }
    set usage [join $options ", "]
    regsub -all -- - $options {} options
    set pat ^-([join $options |])$
    foreach {flag value} $args {
	if {[regexp $pat $flag]} {
	    # Validate numbers
	    if {[info exists parser($flag)] && \
		    [string is integer -strict $parser($flag)] && \
		    ![string is integer -strict $value]} {
		return -code error "Bad value for $flag ($value), must be integer"
	    }
	    set parser($flag) $value
	} else {
	    return -code error "Unknown option $flag, can be: $usage"
	}
    }

    # Backward-compatibility: -baseuri is a synonym for -baseurl
    catch {set parser(-baseuri) $parser(-baseurl)}

    return {}
}

# xml::tclparser::parse --
#
#	Parses document instance data
#
# Arguments:
#	name	parser object
#	xml	data
#	args	configuration options
#
# Results:
#	Callbacks are invoked

proc xml::tclparser::parse {name xml args} {

    array set options $args
    upvar \#0 [namespace current]::$name parser
    variable tokExpr
    variable substExpr

    # Mats:
    if {[llength $args]} {
	eval {configure $name} $args
    }

    set parseOptions [list \
	    -emptyelement [namespace code ParseEmpty] \
	    -parseattributelistcommand [namespace code ParseAttrs] \
	    -parseentitydeclcommand [namespace code ParseEntity] \
	    -normalize 0]
    eval lappend parseOptions \
	    [array get parser -*command] \
	    [array get parser -reportempty] \
	    [array get parser -ignorewhitespace] \
	    [array get parser -name] \
	    [array get parser -cmd] \
	    [array get parser -baseuri] \
	    [array get parser -validate] \
	    [array get parser -final] \
	    [array get parser -defaultexpandinternalentities] \
	    [array get parser entities] \
	    [array get parser extentities] \
	    [array get parser parameterentities] \
	    [array get parser externalparameterentities] \
	    [array get parser elementdecls] \
	    [array get parser attlistdecls] \
	    [array get parser notationdecls]

    # Mats:
    # If -final 0 we also need to maintain the state with a -statevariable !
    if {!$parser(-final)} {
	eval lappend parseOptions [array get parser -statevariable]
    }

    set dtdsubset no
    catch {set dtdsubset $options(-dtdsubset)}
    switch -- $dtdsubset {
	internal {
	    # Bypass normal parsing
	    lappend parseOptions -statevariable $parser(-statevariable)
	    array set intOptions [array get ::sgml::StdOptions]
	    array set intOptions $parseOptions
	    ::sgml::ParseDTD:Internal [array get intOptions] $xml
	    return {}
	}
	external {
	    # Bypass normal parsing
	    lappend parseOptions -statevariable $parser(-statevariable)
	    array set intOptions [array get ::sgml::StdOptions]
	    array set intOptions $parseOptions
	    ::sgml::ParseDTD:External [array get intOptions] $xml
	    return {}
	}
	default {
	    # Pass through to normal processing
	}
    }

    lappend tokenOptions  \
      -internaldtdvariable [namespace current]::${name}(internaldtd)
    
    # Mats: If -final 0 we also need to maintain the state with a -statevariable !
    if {!$parser(-final)} {
	eval lappend tokenOptions [array get parser -statevariable] \
	  [array get parser -final]
    }
    
    # Mats:
    # Why not the first four? Just padding? Lrange undos \n interp.
    # It is necessary to have the first four as well if chopped off in
    # middle of pcdata.
    set tokenised [lrange \
	    [eval {::sgml::tokenise $xml $tokExpr $substExpr} $tokenOptions] \
	0 end]

    lappend parseOptions -internaldtd [list $parser(internaldtd)]
    eval ::sgml::parseEvent [list $tokenised] $parseOptions

    return {}
}

# xml::tclparser::ParseEmpty --  Tcl 8.1+ version
#
#	Used by parser to determine whether an element is empty.
#	This is usually dead easy in XML, but as always not quite.
#	Have to watch out for empty element syntax
#
# Arguments:
#	tag	element name
#	attr	attribute list (raw)
#	e	End tag delimiter.
#
# Results:
#	Return value of e

proc xml::tclparser::ParseEmpty {tag attr e} {
    switch -glob [string length $e],[regexp "/[::xml::cl $::xml::Wsp]*$" $attr] {
	0,0 {
	    return {}
	}
	0,* {
	    return /
	}
	default {
	    return $e
	}
    }
}

# xml::tclparser::ParseAttrs -- Tcl 8.1+ version
#
#	Parse element attributes.
#
# There are two forms for name-value pairs:
#
#	name="value"