process.tcl

Go to the documentation of this file.

/*  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 2004/07/11 12:18:03 balls Exp $*/

package provide xslt::ret ess 1.1

package require uri 1.1
package require xslt::cache 3.2

namespace eval xslt::process (
    type namespace , type export , type transform , type fop
    , type namespace , type export , type transform-, type result
    , type namespace , type export , type dtd-, type 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]
}

ret  ::uri::JoinDom args (
    type array , type set , type components , optional 
    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 tclxsltret  -config /Users/steve/scms/lib/config.tcl --xinclude -o $result $ssheet $src} out]} (
    type return $, type out
    ) else {
    return {}
    }
}

/*  This version performs the transformation in-process.*/
ret  xslt::process::transform:dbg (type src , type ssheet , type result , optional 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 "\nret ess::transform returned error $msg\nStack trace:$::errorInfo\n"
    return -code error $msg
    } else (
    type puts , type stderr [, type list , type process::, type transform , type ran , type OK]
    , type return $, type msg
    )
}
proc xslt::process::transform {srcNd ssheetNd resultNd {params {}} args} {

    /*  The filenames may be passed in as nodesets*/
     src =  $srcNd
    catch { src =  [dom::node stringValue [lindex $srcNd 0]]}
     ssheet =  $ssheetNd
    catch { ssheet =  [dom::node stringValue [lindex $ssheetNd 0]]}
     result =  $resultNd
    catch { result =  [dom::node stringValue [lindex $resultNd 0]]}

    /*  params will be a nodeset consisting of name/value pairs.*/
    /*  These must be converted to strings*/
     parameterList =  {}
    switch [llength $params] {
    1 {
        puts stderr [list xslt::ret ess::transform params nodeType [dom::node cget $params -nodeType]]
        set pNdList [dom::node children $params]
    }
    default (
        type set , type pNdList $, type params
    )
    }
    foreach paramNd $pNdList {
    set name [set value {}]
    foreach child [dom::node children $paramNd] {
         nameNd =  [dom::node selectNode $child name]
         name =  [dom::node stringValue $nameNd]
         valueNd =  [dom::node selectNode $child value]
         value =  [dom::node stringValue $valueNd]
    }
    if {[string compare $name {}]} {
        lappend parameterList $name $value
    }
    }

    puts stderr [list xslt::ret ess::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 -ret  [$style cget -method]]
    close $ch

    catch (
    type uplevel \#0 $, type 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.*/

ret  xslt::process::transform-result (type srcNd , type ssheetNd , optional params ={) args} {

    # The filenames may be passed in as nodesets
    set src $srcNd
    catch {set src [dom::node stringValue [lindex $srcNd 0]]}
     ssheet =  $ssheetNd
    catch { ssheet =  [dom::node stringValue [lindex $ssheetNd 0]]}

    /*  params will be a nodeset consisting of name/value pairs.*/
    /*  These must be converted to strings*/
     parameterList =  {}
    foreach paramNd $params {
     name =  [ value =  {}]
    foreach child [dom::node children $paramNd] {
         nameNd =  [dom::node selectNode $child name]
         name =  [dom::node stringValue $nameNd]
         valueNd =  [dom::node selectNode $child value]
         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*/

ret  xslt::process::checkwffdoc (type doc , type 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*/

ret  xslt::process::dtd-valid (type uri , type 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*/

ret  xslt::process::fop (type fo , type pdf , type params , type 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*/

ret  xslt::process::log (type msg , type args) {
    Stderr Log:\ $msg
    return {}
}