update TEA 3.13

5 files changed, 0 insertions, 1253 deletions

diff --git a/tclxml/tclxslt/process.tcl b/tclxml/tclxslt/process.tcl
deleted file mode 100644
index d38e5fb..0000000
--- a/tclxml/tclxslt/process.tcl
+++ /dev/null
@@ -1,312 +0,0 @@
-# process.tcl --
-#
-#	XSLT extension providing processing functions
-#
-# Copyright (c) 2007 Packaged Press
-# http://www.packagedpress.com/
-# Copyright (c) 2002-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: process.tcl,v 1.1.1.1 2009/01/16 22:11:49 joye Exp $
-
-package provide xslt::process 1.1
-
-package require uri 1.1
-package require xslt::cache 3.2
-
-namespace eval xslt::process {
-    namespace export transform fop
-    namespace export transform-result
-    namespace export dtd-valid
-}
-
-# Add support for the dom: URI scheme.
-#
-# This scheme allows a script to reference an in-memory DOM tree.
-
-proc ::uri::SplitDom url {
-    return [list dom $url]
-}
-
-proc ::uri::JoinDom args {
-    array set components {
-	dom {}
-    }
-    array set components $args
-
-    return dom:$components(dom)
-}
-
-# xslt::process::transform --
-#
-#	Perform an XSL Transformation.
-#
-# TODO:
-#	Return messages
-#	Cache source and stylesheet documents.
-#	Generate dependency documents.
-#
-# Arguments:
-#	src	Location of source document
-#	ssheet	Location of stylesheet
-#	result	Location for result document
-#	params	Parameters (nodelist)
-#	args	not needed
-#
-# Results:
-#	Returns empty string for success
-
-# This version forks a process
-proc xslt::process::transform_fork {src ssheet result {params {}} args} {
-    if {[catch {exec tclxsltproc -config /Users/steve/scms/lib/config.tcl --xinclude -o $result $ssheet $src} out]} {
-	return $out
-    } else {
-	return {}
-    }
-}
-
-# This version performs the transformation in-process.
-proc xslt::process::transform:dbg {src ssheet result {params {}} args} {
-    puts stderr [list process::transform $src $ssheet $result $params $args]
-    if {[catch {eval transform:dbg [list $src $ssheet $result] $params $args} msg]} {
-	puts stderr "\nprocess::transform returned error $msg\nStack trace:$::errorInfo\n"
-	return -code error $msg
-    } else {
-	puts stderr [list process::transform ran OK]
-	return $msg
-    }
-}
-proc xslt::process::transform {srcNd ssheetNd resultNd {params {}} args} {
-
-    # The filenames may be passed in as nodesets
-    set src $srcNd
-    catch {set src [dom::node stringValue [lindex $srcNd 0]]}
-    set ssheet $ssheetNd
-    catch {set ssheet [dom::node stringValue [lindex $ssheetNd 0]]}
-    set result $resultNd
-    catch {set result [dom::node stringValue [lindex $resultNd 0]]}
-
-    # params will be a nodeset consisting of name/value pairs.
-    # These must be converted to strings
-    set parameterList {}
-    switch [llength $params] {
-	1 {
-	    puts stderr [list xslt::process::transform params nodeType [dom::node cget $params -nodeType]]
-	    set pNdList [dom::node children $params]
-	}
-	default {
-	    set pNdList $params
-	}
-    }
-    foreach paramNd $pNdList {
-	set name [set value {}]
-	foreach child [dom::node children $paramNd] {
-	    set nameNd [dom::node selectNode $child name]
-	    set name [dom::node stringValue $nameNd]
-	    set valueNd [dom::node selectNode $child value]
-	    set value [dom::node stringValue $valueNd]
-	}
-	if {[string compare $name {}]} {
-	    lappend parameterList $name $value
-	}
-    }
-
-    puts stderr [list xslt::process::transform parameters: $parameterList]
-
-    set cleanup {}
-
-    if {[catch {open $src} ch]} {
-	# eval $cleanup
-	return "unable to open source document \"$src\" for reading due to \"$ch\""
-    }
-    if {[catch {::dom::parse [read $ch] -baseuri $src} sourcedoc]} {
-	# eval $cleanup
-	return "unable to parse source document \"$src\" due to \"$sourcedoc\""
-    }
-    close $ch
-
-    append cleanup "dom::destroy $sourcedoc" \n
-
-    dom::xinclude $sourcedoc
-
-    if {[catch {open $ssheet} ch]} {
-	eval $cleanup
-	return "unable to open stylesheet document \"$ssheet\" for reading due to \"$ch\""
-    }
-    if {[catch {::dom::parse [read $ch] -baseuri $ssheet} styledoc]} {
-	eval $cleanup
-	return "unable to parse stylesheet document \"$ssheet\" due to \"$styledoc\""
-    }
-    close $ch
-
-    append cleanup "dom::destroy $styledoc" \n
-
-    if {[catch {xslt::compile $styledoc} style]} {
-	eval $cleanup
-	return "unable to compile stylesheet \"$ssheet\" due to \"$style\""
-    }
-
-    append cleanup "rename $style {}" \n
-
-    if {[catch {eval [list $style] transform [list $sourcedoc] $parameterList} resultdoc]} {
-	eval $cleanup
-	return "unable to transform document \"$src\" with stylesheet \"$ssheet\" due to \"$resultdoc\""
-    }
-
-    append cleanup "dom::destroy $resultdoc" \n
-
-    if {[catch {open $result w} ch]} {
-	eval $cleanup
-	return "unable to save result document \"$result\" due to \"$ch\""
-    }
-
-    puts $ch [dom::serialize $resultdoc -method [$style cget -method]]
-    close $ch
-
-    catch {
-	uplevel \#0 $cleanup
-    }
-
-    return {}
-}
-
-# xslt::process::transform-result --
-#
-#	Perform an XSL Transformation.
-#	This version returns the result document.
-#
-# Arguments:
-#	src	Location of source document
-#	ssheet	Location of stylesheet
-#	params	Parameters (nodelist)
-#	args	not needed
-#
-# Results:
-#	Returns result document.
-
-proc xslt::process::transform-result {srcNd ssheetNd {params {}} args} {
-
-    # The filenames may be passed in as nodesets
-    set src $srcNd
-    catch {set src [dom::node stringValue [lindex $srcNd 0]]}
-    set ssheet $ssheetNd
-    catch {set ssheet [dom::node stringValue [lindex $ssheetNd 0]]}
-
-    # params will be a nodeset consisting of name/value pairs.
-    # These must be converted to strings
-    set parameterList {}
-    foreach paramNd $params {
-	set name [set value {}]
-	foreach child [dom::node children $paramNd] {
-	    set nameNd [dom::node selectNode $child name]
-	    set name [dom::node stringValue $nameNd]
-	    set valueNd [dom::node selectNode $child value]
-	    set value [dom::node stringValue $valueNd]
-	}
-	if {[string compare $name {}]} {
-	    lappend parameterList $name $value
-	}
-    }
-
-    if {[catch {eval xslt::cache::transform [list $src $ssheet] $parameterList} rd]} {
-	return "unable to perform transformation due to \"$rd\""
-    }
-
-    return $rd
-}
-
-# xslt::process::checkwffdoc --
-#
-#	Test a document for well-formedness
-#
-# Arguments:
-#	doc	DOM token for document to check
-#	args	not needed
-#
-# Results:
-#	Returns success message
-
-proc xslt::process::checkwffdoc {doc args} {
-    return "of course it's well-formed, it's a DOM tree!"
-}
-
-# xslt::process::dtd-valid --
-#
-#	Test a document for (DTD) validity
-#
-# Arguments:
-#	uri	URI for document to check, supports dom: scheme
-#	args	not needed
-#
-# Results:
-#	Returns success/failure message
-
-proc xslt::process::dtd-valid {uri args} {
-    array set components [uri::split $uri]
-
-    switch -- $components(scheme) {
-	file {
-	    set ch [open $components(path)]
-	    set xmldata [read $ch]
-	    close $ch
-	    set doc [dom::parse $xmldata -baseuri $uri]
-	    set cleanup [list dom::destroy $doc]
-	}
-	dom {
-	    set doc $components(dom)
-	    set cleanup {}
-	}
-	default {
-	    # TODO: support http: scheme
-	    return -code error "unable to resolve entity $uri"
-	}
-    }
-
-    if {[catch {dom::validate $doc} msg]} {
-	set result $msg
-    } else {
-	set result {document is valid}
-    }
-
-    eval $cleanup
-
-    return $result
-}
-
-# xslt::process::fop --
-#
-#	Format an XSL FO document using FOP
-#
-# Arguments:
-#	fo	Location of FO document
-#	pdf	Location for PDF document
-#	params	Parameters (nodelist)
-#	args	not needed
-#
-# Results:
-#	Returns success message
-
-proc xslt::process::fop {fo pdf params args} {
-    return "format fo $fo to produce $pdf"
-}
-
-# xslt::process::log --
-#
-#	Emit a log message.  The application is expected to override this.
-#
-# Arguments:
-#	msg	Log message
-#	args	not needed
-#
-# Results:
-#	None
-
-proc xslt::process::log {msg args} {
-    Stderr Log:\ $msg
-    return {}
-}
-
-
diff --git a/tclxml/tclxslt/resources.tcl b/tclxml/tclxslt/resources.tcl
deleted file mode 100644
index b107a77..0000000
--- a/tclxml/tclxslt/resources.tcl
+++ /dev/null
@@ -1,388 +0,0 @@
-# resources.tcl --
-#
-#	XSLT extension providing access to resources.
-#
-# Copyright (c) 2005-2008 Explain
-# http://www.explain.com.au/
-# Copyright (c) 2001-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: resources.tcl,v 1.1.1.1 2009/01/16 22:11:49 joye Exp $
-
-catch {
-    package require base64
-}
-
-package provide xslt::resources 1.3
-
-namespace eval xslt::resources {
-    namespace export list type exists modified
-}
-
-# xslt::resources::list --
-#
-#	List the resources available at a given location
-#
-# Arguments:
-#	locn	Resource path to list
-#	basedir	Base directory
-#	args	not needed
-#
-# Results:
-#	Returns list of resources
-
-proc xslt::resources::list {locnNd {baseNd {}} args} {
-    # What kind of resource is this?  file, http, ftp, etc?
-
-    if {[llength $args]} {
-	return -code error "too many arguments"
-    }
-
-    set locn $locnNd
-    # The resource may be passed in as a nodeset
-    catch {set locn [dom::node stringValue [lindex $locnNd 0]]}
-    set base $baseNd
-    catch {set base [dom::node stringValue [lindex $baseNd 0]]}
-
-    if {[string match /* $base]} {
-	regsub {^(/)} $locn {} locn
-    }
-
-    set result {}
-    foreach entry [glob -nocomplain [file join $base $locn *]] {
-	lappend result [file tail $entry]
-    }
-
-    return $result
-}
-
-# xslt::resources::type --
-#
-#	Gives the type of the resource
-#
-# Arguments:
-#	locn	Resource path to type
-#	args	not needed
-#
-# Results:
-#	Returns string describing resource
-
-proc xslt::resources::type {locnNd args} {
-
-    if {[llength $args]} {
-	return -code error "too many arguments"
-    }
-
-    set locn $locnNd
-    catch {set locn [dom::node stringValue [lindex $locnNd 0]]}
-
-    if {[file isdir $locn]} {
-	return directory
-    } elseif {[file isfile $locn]} {
-	return file
-    } else {
-	return other
-    }
-}
-
-# xslt::resources::exists --
-#
-#	Check whether a resource exists
-#
-# Arguments:
-#	locn	Resource path to type
-#	args	not needed
-#
-# Results:
-#	Returns boolean
-
-proc xslt::resources::exists {locnNd args} {
-
-    if {[llength $args]} {
-	return -code error "too many arguments"
-    }
-
-    set locn $locnNd
-    catch {set locn [dom::node stringValue [lindex $locnNd 0]]}
-
-    if {[file exists $locn]} {
-	return 1
-    } else {
-	return 0
-    }
-}
-
-# xslt::resources::modified --
-#
-#	Report last modification time of a resource
-#
-# Arguments:
-#	locn	Resource path
-#	args	not needed
-#
-# Results:
-#	Returns ISO standard date-time string
-
-proc xslt::resources::modified {locnNd args} {
-
-    if {[llength $args]} {
-	return -code error "too many arguments"
-    }
-
-    set locn $locnNd
-    catch {set locn [dom::node stringValue [lindex $locnNd 0]]}
-
-    if {[file exists $locn]} {
-	return [clock format [file mtime $locn] -format {%Y-%m-%dT%H:%M:%S}]
-    } else {
-	return {}
-    }
-}
-
-# xslt::resources::mkdir --
-#
-#	Create a directory hierarchy.
-#
-# Arguments:
-#	locn	Resource path for directory
-#	args	not needed
-#
-# Results:
-#	Returns directory created or empty string if unsuccessful
-
-proc xslt::resources::mkdir {locnNd args} {
-
-    if {[llength $args]} {
-	return {}
-    }
-
-    set locn $locnNd
-    catch {set locn [dom::node stringValue [lindex $locnNd 0]]}
-
-    set dir [file split $locn]
-    set current [lindex $dir 0]
-    set remaining [lrange $dir 1 end]
-    while {[llength $remaining]} {
-	set current [file join $current [lindex $remaining 0]]
-	set remaining [lrange $remaining 1 end]
-	if {[file exists $current]} {
-	    if {![file isdir $current]} {
-		return {}
-	    }
-	} elseif {[file isdir $current]} {
-	    continue
-	} else {
-	    if {[catch {file mkdir $current}]} {
-		return {}
-	    }
-	}
-    }
-
-    return $locn
-}
-
-# xslt::resources::copy --
-#
-#	Copy a resource.
-#
-# Arguments:
-#	src	Resource to copy
-#	dest	Destination for resource
-#	args	not needed
-#
-# Results:
-#	Resource copied
-
-proc xslt::resources::copy {srcNd destNd args} {
-    set src $srcNd
-    catch {set src [dom::node stringValue [lindex $srcNd 0]]}
-    set dest $destNd
-    catch {set dest [dom::node stringValue [lindex $destNd 0]]}
-
-    if {[catch {file copy -force $src $dest} msg]} {
-	catch {
-	    package require log
-	    log::log error "copy failed due to \"$msg\""
-	}
-	return 0
-    } else {
-	return 1
-    }
-}
-
-# xslt::resources::move --
-#
-#	Move (rename) a resource.
-#
-# Arguments:
-#	src	Resource to move
-#	dest	Destination for resource
-#	args	not needed
-#
-# Results:
-#	Resource renamed
-
-proc xslt::resources::move {srcNd destNd args} {
-    set src $srcNd
-    catch {set src [dom::node stringValue [lindex $srcNd 0]]}
-    set dest $destNd
-    catch {set dest [dom::node stringValue [lindex $destNd 0]]}
-
-    if {[catch {file rename -force $src $dest}]} {
-	return 0
-    } else {
-	return 1
-    }
-}
-
-# xslt::resources::file-attributes --
-#
-#	Change attributes of a resource.
-#
-# Arguments:
-#	src	Resource to change
-#	what	Attribute to change
-#	detail	Attribute value
-#	args	not needed
-#
-# Results:
-#	Resource attribute changed
-
-proc xslt::resources::file-set-attributes {srcNd whatNd detailNd args} {
-    set src $srcNd
-    catch {set src [dom::node stringValue [lindex $srcNd 0]]}
-    set what $whatNd
-    catch {set what [dom::node stringValue [lindex $whatNd 0]]}
-    set detail $detailNd
-    catch {set detail [dom::node stringValue [lindex $detailNd 0]]}
-
-    if {[catch {file attributes $src -$what $detail} result]} {
-	return {}
-    } else {
-	return $result
-    }
-}
-
-# xslt::resources::delete --
-#
-#	Delete a resource
-#
-# Arguments:
-#	locn	Resource path to type
-#	args	not needed
-#
-# Results:
-#	Returns boolean
-
-proc xslt::resources::delete {locnNd args} {
-
-    if {[llength $args]} {
-	return -code error "too many arguments"
-    }
-
-    set locn $locnNd
-    catch {set locn [dom::node stringValue [lindex $locnNd 0]]}
-
-    if {[catch {file delete -force $locn} msg]} {
-	catch {
-	    package require log
-	    log::log error "delete failed due to \"$msg\""
-	}
-	return 0
-    } else {
-	return 1
-    }
-}
-
-# xslt::resources::link --
-#
-#	Link a resource.
-#
-# Arguments:
-#	from	Link to create
-#	to	Target of link
-#	args	not needed
-#
-# Results:
-#	Symbolic link created
-
-proc xslt::resources::link {fromNd toNd args} {
-    set from $fromNd
-    catch {set from [dom::node stringValue [lindex $fromNd 0]]}
-    set to $toNd
-    catch {set to [dom::node stringValue [lindex $toNd 0]]}
-
-    if {[catch {file link $from $to}]} {
-	return 0
-    } else {
-	return 1
-    }
-}
-
-# xslt::resources::write-base64 --
-#
-#	Decode base64 encoded data and write the binary data to a file
-#
-# Arguments:
-#	fname	Filename
-#	b64	base64 encoded data
-#	args	not needed
-#
-# Results:
-#	File opened for writing and binary data written.
-#	Returns 1 if file successfully written, 0 otherwise.
-
-proc xslt::resources::write-base64 {fnameNd b64Nd args} {
-    set fname $fnameNd
-    catch {set fname [dom::node stringValue [lindex $fnameNd 0]]}
-    set b64 $b64Nd
-    catch {set b64 [dom::node stringValue [lindex $b64Nd 0]]}
-
-    if {[catch {package require base64}]} {
-	return 0
-    }
-
-    if {[catch {open $fname w} ch]} {
-	return 0
-    } else {
-	set binarydata [base64::decode $b64]
-	fconfigure $ch -trans binary -encoding binary
-	puts -nonewline $ch $binarydata
-	close $ch
-	return 1
-    }
-}
-
-# xslt::resources::read-base64 --
-#
-#	Read binary data from a file and base64 encode it
-#
-# Arguments:
-#	fname	Filename
-#	args	not needed
-#
-# Results:
-#	File opened for readng and contents read.
-#	Returns content as base64-encoded data.
-
-proc xslt::resources::read-base64 {fnameNd args} {
-    set fname $fnameNd
-    catch {set fname [dom::node stringValue [lindex $fnameNd 0]]}
-
-    if {[catch {package require base64}]} {
-	return 0
-    }
-
-    if {[catch {open $fname} ch]} {
-	return 0
-    } else {
-	fconfigure $ch -trans binary -encoding binary
-	set binarydata [read $ch]
-	close $ch
-	return [base64::encode $binarydata]
-    }
-}
-
diff --git a/tclxml/tclxslt/tclxslt.tcl b/tclxml/tclxslt/tclxslt.tcl
deleted file mode 100644
index 6aa6a2c..0000000
--- a/tclxml/tclxslt/tclxslt.tcl
+++ /dev/null
@@ -1,30 +0,0 @@
-# tclxslt.tcl --
-#
-#	Tcl library for TclXSLT package.
-#
-# Copyright (c) 2001-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: tclxslt.tcl,v 1.1.1.1 2009/01/16 22:11:49 joye Exp $
-
-namespace eval xslt {
-    namespace export getprocs
-}
-
-proc xslt::getprocs ns {
-    set functions {}
-    set elements {}
-    foreach proc [info commands ${ns}::*] {
-	if {[regexp {::([^:]+)$} $proc discard name]} {
-	    if {[string equal [lindex [info args $proc] end] "args"]} {
-		lappend functions $name
-	    } else {
-		lappend elements $name
-	    }
-	}
-    }
-    return [list $elements $functions]
-}
diff --git a/tclxml/tclxslt/utilities.tcl b/tclxml/tclxslt/utilities.tcl
deleted file mode 100644
index 8459598..0000000
--- a/tclxml/tclxslt/utilities.tcl
+++ /dev/null
@@ -1,144 +0,0 @@
-# utilities.tcl --
-#
-#	Miscellaneous extension functions for XSLT.
-#
-# Copyright (c) 2007 Explain
-# http://www.explain.com.au/
-# Copyright (c) 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: utilities.tcl,v 1.1.1.1 2009/01/16 22:11:49 joye Exp $
-
-package provide xslt::utilities 1.2
-
-namespace eval xslt::utilities {
-    namespace export character-first decode-base64
-}
-
-# xslt::utilities::character-first --
-#
-#	Returns the character that occurs first from a string
-#	of possible characters.
-#
-# Arguments:
-#	src	source string
-#	chars	characters to find
-#	args	not needed
-#
-# Results:
-#	Returns a character or empty string.
-
-proc xslt::utilities::character-first {srcNd charsNd args} {
-    if {[llength $args]} {
-	return -code error "too many arguments"
-    }
-
-    set src $srcNd
-    catch {set src [dom::node stringValue [lindex $srcNd 0]]}
-    set chars $charsNd
-    catch {set chars [dom::node stringValue [lindex $charsNd 0]]}
-
-    regsub -all {([\\\[\]^$-])} $chars {\\\1} chars
-    if {[regexp [format {([%s])} $chars] $src dummy theChar]} {
-	return $theChar
-    }
-
-    return {}
-}
-
-# xslt::utilities::decode-base64 --
-#
-#	Returns decoded (binary) base64-encoded data.
-#
-# Arguments:
-#	src	source string
-#	args	not needed
-#
-# Results:
-#	Returns binary data.
-
-proc xslt::utilities::decode-base64 {srcNd args} {
-    if {[llength $args]} {
-	return -code error "too many arguments"
-    }
-
-    if {[catch {package require base64}]} {
-	return {}
-    }
-
-    set src $srcNd
-    catch {set src [dom::node stringValue [lindex $srcNd 0]]}
-
-    return [base64::decode $src]
-}
-
-# xslt::utilities::binary-document --
-#
-#	Writes binary data into a document
-#	(this should be an extension element)
-#
-# Arguments:
-#	fname	filename
-#	data	binary data
-#	args	not needed
-#
-# Results:
-#	File opened for writing and data written.
-#	Returns 1 on success, 0 otherwise
-
-proc xslt::utilities::binary-document {fnameNd srcNd args} {
-    if {[llength $args]} {
-	return -code error "too many arguments"
-    }
-
-    set fname $fnameNd
-    catch {set fname [dom::node stringValue [lindex $fnameNd 0]]}
-    set data $dataNd
-    catch {set data [dom::node stringValue [lindex $dataNd 0]]}
-
-    if {[catch {open $fname w} ch]} {
-	return 0
-    }
-    fconfigure $ch -trans binary -encoding binary
-    puts -nonewline $ch $data
-    close $ch
-
-    return 1
-}
-
-# xslt::utilities::base64-binary-document --
-#
-#	Returns base64-encoded data from a file.
-#
-# Arguments:
-#	fname	filename
-#	args	not needed
-#
-# Results:
-#	Returns text.  Returns empty string on error.
-
-proc xslt::utilities::base64-binary-document {fnameNd args} {
-    if {[llength $args]} {
-	return -code error "too many arguments"
-    }
-
-    if {[catch {package require base64}]} {
-	return {}
-    }
-
-    set fname $fnameNd
-    catch {set fname [dom::node stringValue [lindex $fnameNd 0]]}
-
-    if {[catch {open $fname} ch]} {
-	return {}
-    }
-    fconfigure $ch -trans binary -encoding binary
-    set data [read $ch]
-    close $ch
-
-    return [base64::encode $data]
-}
-
diff --git a/tclxml/tclxslt/xsltcache.tcl b/tclxml/tclxslt/xsltcache.tcl
deleted file mode 100644
index 9a3d8f7..0000000
--- a/tclxml/tclxslt/xsltcache.tcl
+++ /dev/null
@@ -1,379 +0,0 @@
-# xsltcache.tcl --
-#
-#	Handles performing XSLT transformations,
-#	caching documents and results.
-#
-# Copyright (c) 2005-2007 Steve Ball
-# http://www.packagedpress.com/staff/Steve.Ball
-# Copyright (c) 2002-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: xsltcache.tcl,v 1.1.1.1 2009/01/16 22:11:49 joye Exp $
-
-package require xslt 3.2
-package require uri
-
-package provide xslt::cache 3.2
-
-namespace eval xslt::cache {
-    namespace export transform transformdoc flush
-    namespace export parse_depend
-    namespace export loadstylesheet
-
-    variable sources
-    array set sources {}
-    variable stylesheets
-    array set stylesheets {}
-    variable results
-    array set results {}
-}
-
-# xslt::cache::transform --
-#
-#	Perform an XSLT transformation.
-#
-# Arguments:
-#	src	Filename of source document
-#	ssheet	Filename of stylesheet document
-#	args	Configuration options, stylesheet parameters
-#
-# Results:
-#	Result document token
-
-proc xslt::cache::transform {src ssheet args} {
-    variable sources
-    variable stylesheets
-    variable results
-
-    # Separate parameters from options
-    set parameters {}
-    set options {}
-    foreach {key value} $args {
-	switch -glob -- $key {
-	    -* {
-		lappend options $key $value
-	    }
-	    default {
-		lappend parameters $key $value
-	    }
-	}
-    }
-
-    # Normalize the parameter list
-    array set paramArray $parameters
-    set parameters {}
-    foreach name [lsort [array names paramArray]] {
-	lappend parameters $name $paramArray($name)
-    }
-
-    set hash $src.$ssheet.$parameters
-
-    array set opts {
-	-xmlinclude 1
-    }
-    array set opts $options
-
-    set readSource [ReadXML $src -xmlinclude $opts(-xmlinclude)]
-
-    set readStylesheet 1
-    if {[info exists stylesheets($ssheet)]} {
-	if {[file mtime $ssheet] < $stylesheets($ssheet,time)} {
-	    set readStylesheet 0
-	}
-    }
-    if {$readStylesheet} {
-	catch {rename $stylesheets($ssheet) {}}
-	ReadXML $ssheet -xmlinclude $opts(-xmlinclude)
-
-	set stylesheets($ssheet) [xslt::compile $sources($ssheet)]
-	set stylesheets($ssheet,time) [clock seconds]
-    }
-
-    if {$readSource || $readStylesheet || ![info exists results($hash)]} {
-
-	set results($hash) [eval [list $stylesheets($ssheet)] transform [list $sources($src)] $parameters]
-	set results($hash,time) [clock seconds]
-    }
-
-    return $results($hash)
-}
-
-# xslt::cache::loadstylesheet --
-#
-#	Read, parse and compile an XSLT stylesheet.
-#
-# Arguments:
-#	src	Filename for the stylesheet document
-#	args	options
-#
-# Results:
-#	Returns compiled stylesheet token.  Adds reference to stylesheet to cache.
-
-proc xslt::cache::loadstylesheet {src args} {
-    variable sources
-    variable stylesheets
-
-    array set options {
-	-keepsource 0
-	-xmlinclude 0
-    }
-    array set options $args
-
-    eval ReadXML [list $src] [array get options -xmlinclude]
-
-    set stylesheets($src) [xslt::compile $sources($src)]
-    set stylesheets($src,time) [clock seconds]
-
-    if {!$options(-keepsource)} {
-	flush $src {}
-    }
-
-    # TODO: set command trace so that if the stylesheet is deleted
-    # the cache is invalidated
-
-    return $stylesheets($src)
-}
-
-# xslt::cache::ReadXML --
-#
-#	Internal proc to manage parsing a document.
-#	Used for both source and stylesheet documents.
-#
-# Arguments:
-#	src	Filename of source document
-#	args	Configuration options
-#
-# Results:
-#	Returns 1 if document was read.  Returns 0 if document is cached.
-
-proc xslt::cache::ReadXML {src args} {
-    variable sources
-    array set opts {
-	-xmlinclude 1
-    }
-    array set opts $args
-
-    set readSource 1
-    if {[info exists sources($src)]} {
-	if {[file mtime $src] < $sources($src,time)} {
-	    set readSource 0
-	}
-    }
-    if {$readSource} {
-	catch {dom::destroy $sources($src)}
-	set ch [open $src]
-	set sources($src) [dom::parse [read $ch] -baseuri file://$src]
-	close $ch
-	if {$opts(-xmlinclude)} {
-	    dom::xinclude $sources($src)
-	}
-	set sources($src,time) [clock seconds]
-    }
-
-    return $readSource
-}
-
-# xslt::cache::transformdoc --
-#
-#	Perform an XSLT transformation on a DOM document.
-#
-# Arguments:
-#	src	DOM token of source document
-#	ssheet	Filename of stylesheet document
-#	args	Configuration options, stylesheet parameters
-#
-# Results:
-#	Result document token
-
-proc xslt::cache::transformdoc {src ssheet args} {
-    variable sources
-    variable stylesheets
-
-    # Separate parameters from options
-    set parameters {}
-    set options {}
-    foreach {key value} $args {
-	switch -glob -- $key {
-	    -* {
-		lappend options $key $value
-	    }
-	    default {
-		lappend parameters $key $value
-	    }
-	}
-    }
-
-    # Normalize the parameter list
-    array set paramArray $parameters
-    set parameters {}
-    foreach name [lsort [array names paramArray]] {
-	lappend parameters $name $paramArray($name)
-    }
-
-    array set opts {
-	-xmlinclude 1
-    }
-    array set opts $options
-
-    set readStylesheet 1
-    if {[info exists stylesheets($ssheet)]} {
-	if {[file mtime $ssheet] < $stylesheets($ssheet,time)} {
-	    set readStylesheet 0
-	}
-    }
-    if {$readStylesheet} {
-	catch {rename $stylesheets($ssheet) {}}
-	ReadXML $ssheet -xmlinclude $opts(-xmlinclude)
-
-	set stylesheets($ssheet) [xslt::compile $sources($ssheet)]
-	set stylesheets($ssheet,time) [clock seconds]
-    }
-
-    set result [eval [list $stylesheets($ssheet)] transform [list $src] $parameters]
-
-    return $result
-}
-
-# ::xslt::cache::parse_depend --
-#
-#	Parse a document while determining its dependencies.
-#
-# Arguments:
-#	uri	Document's URI
-#	depVar	Global variable name for dependency document
-#
-# Results:
-#	Returns parsed document token.
-#	Document token for dependency document is stored in depVar.
-
-proc xslt::cache::parse_depend {uri depVar} {
-    upvar #0 $depVar dep
-
-    set dep [dom::create]
-    dom::document createElement $dep dependencies
-
-    array set uriParsed [uri::split $uri]
-
-    switch -- $uriParsed(scheme) {
-	file {
-	    set ch [open $uriParsed(path)]
-	    set doc [dom::parse [read $ch] -baseuri $uri -externalentitycommand [namespace code [list ParseDepend_Entity $depVar]]]
-	    close $ch
-
-	    ParseDepend_XInclude $doc $depVar
-	    ParseDepend_XSLT $doc $depVar
-	}
-	http {
-	    return -code error "URI scheme \"http\" not yet implemented"
-	}
-	dom {
-	    set doc $uriParsed(dom)
-
-	    # Can't determine external entities, but can find XInclude
-	    # and XSL stylesheet includes/imports.
-	    ParseDepend_XInclude $uriParsed(dom) $depVar
-	    ParseDepend_XSLT $uriParsed(dom) $depVar
-	}
-	default {
-	    return -code error "URI scheme \"$uriParsed(scheme)\" not supported"
-	}
-    }
-
-    return $doc
-}
-
-# xslt::cache::ParseDepend_Entity --
-#
-#	Callback for external entity inclusion.
-#
-# Arguments:
-#	depVar	Global variable of dependency document
-#	pubId	Public identifier
-#	sysId	System identifier
-#
-# Results:
-#	Dependency added to dependency document
-
-proc xslt::cache::ParseDepend_Entity {depVar pubId sysId} {
-    upvar #0 $depVar dep
-
-    dom::document createNode $dep /dependencies/external-entities/entity
-}
-
-# ::xslt::cache::flush --
-#
-#	Flush the cache
-#
-# Arguments:
-#	src	source document filename
-#	ssheet	stylesheet document filename
-#	args	parameters
-#
-# Results:
-#	Returns the empty string.
-#	If all arguments are given then all entries corresponding
-#	to that transformation are destroyed.
-#	If the source and/or stylesheet are given then all
-#	entries corresponding to those documents are destroyed.
-
-proc xslt::cache::flush {src ssheet args} {
-    variable sources
-    variable stylesheets
-    variable results
-
-    # Normalize parameter list
-    array set paramArray $args
-    set parameters {}
-    foreach name [lsort [array names paramArray]] {
-	lappend parameters $name $paramArray($name)
-    }
-
-    set hash $src.$ssheet.$parameters
-
-    switch -glob [string length $src],[string length $ssheet],[llength $args] {
-	0,0,* {
-	    # Special case: flush all
-	    unset sources
-	    array set sources {}
-	    unset stylesheets
-	    array set stylesheets {}
-	    unset results
-	    array set results {}
-	}
-
-	0,*,0 {
-	    # Flush all entries for the given stylesheet
-	    catch {rename $stylesheets($ssheet) {}}
-	    catch {unset stylesheets($ssheet)}
-	    catch {unset stylesheets($ssheet,time)}
-
-	    foreach entry [array names results *.$ssheet.*] {
-		catch {dom::destroy $results($entry)}
-		catch {unset results($entry)}
-		catch {unset results($entry,time)}
-	    }
-	}
-
-	*,0,0 {
-	    # Flush all entries for the given source document
-	    catch {dom::destroy $sources($src)}
-	    catch {unset sources($src)}
-	    catch {unset sources($src,time)}
-	    foreach entry [array names results $src.*] {
-		catch {dom::destroy $results($entry)}
-		catch {unset results($entry)}
-		catch {unset results($entry,time)}
-	    }
-	}
-
-	default {
-	    # Flush specific entry
-	    catch {dom::destroy $results($hash)}
-	    catch {unset results($hash)}
-	    catch {unset results($hash,time)}
-	}
-    }
-}