summaryrefslogtreecommitdiffstats
path: root/tclxml-tcl/xml__tcl.tcl
diff options
context:
space:
mode:
authorWilliam Joye <wjoye@cfa.harvard.edu>2016-10-27 20:17:32 (GMT)
committerWilliam Joye <wjoye@cfa.harvard.edu>2016-10-27 20:17:32 (GMT)
commit55c7ed6e4d159cebe06999bf61e668284a89cd69 (patch)
tree6d6bf28a07bdc5134679d3dc52db7dfa1634ea64 /tclxml-tcl/xml__tcl.tcl
downloadblt-55c7ed6e4d159cebe06999bf61e668284a89cd69.zip
blt-55c7ed6e4d159cebe06999bf61e668284a89cd69.tar.gz
blt-55c7ed6e4d159cebe06999bf61e668284a89cd69.tar.bz2
Squashed 'tclxml/' content from commit f0c7712
git-subtree-dir: tclxml git-subtree-split: f0c77122f0c2a2f9c84c605da8dec0d35a0aa747
Diffstat (limited to 'tclxml-tcl/xml__tcl.tcl')
-rw-r--r--tclxml-tcl/xml__tcl.tcl272
1 files changed, 272 insertions, 0 deletions
diff --git a/tclxml-tcl/xml__tcl.tcl b/tclxml-tcl/xml__tcl.tcl
new file mode 100644
index 0000000..bdb7bd9
--- /dev/null
+++ b/tclxml-tcl/xml__tcl.tcl
@@ -0,0 +1,272 @@
+# xml__tcl.tcl --
+#
+# This file provides a Tcl implementation of the parser
+# class support found in ../tclxml.c. It is only used
+# when the C implementation is not installed (for some reason).
+#
+# Copyright (c) 2005 by Explain.
+# http://www.explain.com.au/
+# Copyright (c) 2000-2004 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: xml__tcl.tcl,v 1.1.1.1 2009/01/16 22:11:49 joye Exp $
+
+package provide xml::tcl 3.2
+
+namespace eval xml {
+ namespace export configure parser parserclass
+
+ # Parser implementation classes
+ variable classes
+ array set classes {}
+
+ # Default parser class
+ variable default {}
+
+ # Counter for generating unique names
+ variable counter 0
+}
+
+# xml::configure --
+#
+# Configure the xml package
+#
+# Arguments:
+# None
+#
+# Results:
+# None (not yet implemented)
+
+proc xml::configure args {}
+
+# xml::parserclass --
+#
+# Implements the xml::parserclass command for managing
+# parser implementations.
+#
+# Arguments:
+# method subcommand
+# args method arguments
+#
+# Results:
+# Depends on method
+
+proc xml::parserclass {method args} {
+ variable classes
+ variable default
+
+ switch -- $method {
+
+ create {
+ if {[llength $args] < 1} {
+ return -code error "wrong number of arguments, should be xml::parserclass create name ?args?"
+ }
+
+ set name [lindex $args 0]
+ if {[llength [lrange $args 1 end]] % 2} {
+ return -code error "missing value for option \"[lindex $args end]\""
+ }
+ array set classes [list $name [list \
+ -createcommand [namespace current]::noop \
+ -createentityparsercommand [namespace current]::noop \
+ -parsecommand [namespace current]::noop \
+ -configurecommand [namespace current]::noop \
+ -getcommand [namespace current]::noop \
+ -deletecommand [namespace current]::noop \
+ ]]
+ # BUG: we're not checking that the arguments are kosher
+ set classes($name) [lrange $args 1 end]
+ set default $name
+ }
+
+ destroy {
+ if {[llength $args] < 1} {
+ return -code error "wrong number of arguments, should be xml::parserclass destroy name"
+ }
+
+ if {[info exists classes([lindex $args 0])]} {
+ unset classes([lindex $args 0])
+ } else {
+ return -code error "no such parser class \"[lindex $args 0]\""
+ }
+ }
+
+ info {
+ if {[llength $args] < 1} {
+ return -code error "wrong number of arguments, should be xml::parserclass info method"
+ }
+
+ switch -- [lindex $args 0] {
+ names {
+ return [array names classes]
+ }
+ default {
+ return $default
+ }
+ }
+ }
+
+ default {
+ return -code error "unknown method \"$method\""
+ }
+ }
+
+ return {}
+}
+
+# xml::parser --
+#
+# Create a parser object instance
+#
+# Arguments:
+# args optional name, configuration options
+#
+# Results:
+# Returns object name. Parser instance created.
+
+proc xml::parser args {
+ variable classes
+ variable default
+
+ if {[llength $args] < 1} {
+ # Create unique name, no options
+ set parserName [FindUniqueName]
+ } else {
+ if {[string index [lindex $args 0] 0] == "-"} {
+ # Create unique name, have options
+ set parserName [FindUniqueName]
+ } else {
+ # Given name, optional options
+ set parserName [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ }
+
+ array set options [list \
+ -parser $default
+ ]
+ array set options $args
+
+ if {![info exists classes($options(-parser))]} {
+ return -code error "no such parser class \"$options(-parser)\""
+ }
+
+ # Now create the parser instance command and data structure
+ # The command must be created in the caller's namespace
+ uplevel 1 [list proc $parserName {method args} "eval [namespace current]::ParserCmd [list $parserName] \[list \$method\] \$args"]
+ upvar #0 [namespace current]::$parserName data
+ array set data [list class $options(-parser)]
+
+ array set classinfo $classes($options(-parser))
+ if {[string compare $classinfo(-createcommand) ""]} {
+ eval $classinfo(-createcommand) [list $parserName]
+ }
+ if {[string compare $classinfo(-configurecommand) ""] && \
+ [llength $args]} {
+ eval $classinfo(-configurecommand) [list $parserName] $args
+ }
+
+ return $parserName
+}
+
+# xml::FindUniqueName --
+#
+# Generate unique object name
+#
+# Arguments:
+# None
+#
+# Results:
+# Returns string.
+
+proc xml::FindUniqueName {} {
+ variable counter
+ return xmlparser[incr counter]
+}
+
+# xml::ParserCmd --
+#
+# Implements parser object command
+#
+# Arguments:
+# name object reference
+# method subcommand
+# args method arguments
+#
+# Results:
+# Depends on method
+
+proc xml::ParserCmd {name method args} {
+ variable classes
+ upvar #0 [namespace current]::$name data
+
+ array set classinfo $classes($data(class))
+
+ switch -- $method {
+
+ configure {
+ # BUG: We're not checking for legal options
+ array set data $args
+ eval $classinfo(-configurecommand) [list $name] $args
+ return {}
+ }
+
+ cget {
+ return $data([lindex $args 0])
+ }
+
+ entityparser {
+ set new [FindUniqueName]
+
+ upvar #0 [namespace current]::$name parent
+ upvar #0 [namespace current]::$new data
+ array set data [array get parent]
+
+ uplevel 1 [list proc $new {method args} "eval [namespace current]::ParserCmd [list $new] \[list \$method\] \$args"]
+
+ return [eval $classinfo(-createentityparsercommand) [list $name $new] $args]
+ }
+
+ free {
+ eval $classinfo(-deletecommand) [list $name]
+ unset data
+ uplevel 1 [list rename $name {}]
+ }
+
+ get {
+ eval $classinfo(-getcommand) [list $name] $args
+ }
+
+ parse {
+ if {[llength $args] < 1} {
+ return -code error "wrong number of arguments, should be $name parse xml ?options?"
+ }
+ eval $classinfo(-parsecommand) [list $name] $args
+ }
+
+ reset {
+ eval $classinfo(-resetcommand) [list $name]
+ }
+
+ default {
+ return -code error "unknown method"
+ }
+ }
+
+ return {}
+}
+
+# xml::noop --
+#
+# Do nothing utility proc
+#
+# Arguments:
+# args whatever
+#
+# Results:
+# Nothing happens
+
+proc xml::noop args {}