summaryrefslogtreecommitdiffstats
path: root/tclxml/tclxslt
diff options
context:
space:
mode:
Diffstat (limited to 'tclxml/tclxslt')
-rw-r--r--tclxml/tclxslt/process.tcl312
-rw-r--r--tclxml/tclxslt/resources.tcl388
-rw-r--r--tclxml/tclxslt/tclxslt.tcl30
-rw-r--r--tclxml/tclxslt/utilities.tcl144
-rw-r--r--tclxml/tclxslt/xsltcache.tcl379
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)}
- }
- }
-}
generated by cgit v0.12 at 2024-11-20 05:52:10 (GMT)