diff options
Diffstat (limited to 'tclxml/tclxslt')
| -rw-r--r-- | tclxml/tclxslt/process.tcl | 312 | ||||
| -rw-r--r-- | tclxml/tclxslt/resources.tcl | 388 | ||||
| -rw-r--r-- | tclxml/tclxslt/tclxslt.tcl | 30 | ||||
| -rw-r--r-- | tclxml/tclxslt/utilities.tcl | 144 | ||||
| -rw-r--r-- | tclxml/tclxslt/xsltcache.tcl | 379 |
5 files changed, 1253 insertions, 0 deletions
diff --git a/tclxml/tclxslt/process.tcl b/tclxml/tclxslt/process.tcl new file mode 100644 index 0000000..d38e5fb --- /dev/null +++ b/tclxml/tclxslt/process.tcl @@ -0,0 +1,312 @@ +# 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 new file mode 100644 index 0000000..b107a77 --- /dev/null +++ b/tclxml/tclxslt/resources.tcl @@ -0,0 +1,388 @@ +# 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 new file mode 100644 index 0000000..6aa6a2c --- /dev/null +++ b/tclxml/tclxslt/tclxslt.tcl @@ -0,0 +1,30 @@ +# 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 new file mode 100644 index 0000000..8459598 --- /dev/null +++ b/tclxml/tclxslt/utilities.tcl @@ -0,0 +1,144 @@ +# 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 new file mode 100644 index 0000000..9a3d8f7 --- /dev/null +++ b/tclxml/tclxslt/xsltcache.tcl @@ -0,0 +1,379 @@ +# 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)} + } + } +} |