(* Copyright (C) 2002, HELM Team.
*
* This file is part of HELM, an Hypertextual, Electronic
* Library of Mathematics, developed at the Computer Science
* Department, University of Bologna, Italy.
*
* HELM is free software; you can redistribute it and/or
* modify it under the terms of the GNU General Public License
* as published by the Free Software Foundation; either version 2
* of the License, or (at your option) any later version.
*
* HELM is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with HELM; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston,
* MA 02111-1307, USA.
*
* For details, see the HELM World-Wide-Web page,
* http://cs.unibo.it/helm/.
*)
open Printf;;
open Uwobo_common;;
exception Unsupported_property of string;;
let supported_properties = [
"cdata-section-elements";
"doctype-public";
"doctype-system";
"encoding";
"indent";
"media-type";
"method";
"omit-xml-declaration";
"standalone";
"version"
]
let dump_args keys params props =
(sprintf "
Keys: %s
Parameters:
%s
Props: %s
"
(String.concat ", " keys)
(String.concat
"
\n"
(List.map
(fun key ->
(sprintf
"Key: %s, Params: %s"
key
(String.concat
", "
(List.map
(fun (key,value) -> sprintf "%s:%s" key value)
(params key)))))
keys))
(String.concat
", "
(List.map (fun (key,value) -> sprintf "%s:%s" key value) props)))
let xslNS = Gdome.domString "http://www.w3.org/1999/XSL/Transform"
let outputS = Gdome.domString "output"
let q_outputS = Gdome.domString "xsl:output"
let is_supported_property name = List.mem name supported_properties
(** set a list of output properties in an xslt stylesheet, return a copy of
the given stylesheet modified as needed, given stylesheet wont be changed by
this operation *)
let apply_properties logger last_stylesheet props =
let last_stylesheet =
new Gdome.document_of_node (last_stylesheet#cloneNode ~deep:true)
in
let output_element =
let node_list = last_stylesheet#getElementsByTagNameNS xslNS outputS in
(match node_list#item 0 with
| None -> (* no xsl:output element, create it from scratch *)
logger#log `Debug "Creating xsl:output node ...";
let elt = last_stylesheet#createElementNS (Some xslNS) q_outputS in
let root = last_stylesheet#get_documentElement in
ignore (root#appendChild (elt :> Gdome.node));
elt
| Some node -> new Gdome.element_of_node node)
in
let apply_property (name, value) =
if is_supported_property name then begin
logger#log `Debug (sprintf "Setting property: %s = %s" name value);
output_element#setAttribute
(Gdome.domString name)
(Gdome.domString value)
end
else
raise (Unsupported_property name)
in
List.iter apply_property props;
last_stylesheet
(** given a Gdome.document representing an XSLT stylesheet and an output
property return 'Some value' where 'value' is the property value, or None if
it's not defined *)
let get_property name (document: Gdome.document) =
let node_list = document#getElementsByTagNameNS xslNS outputS in
match node_list#item 0 with
| None -> None
| Some node ->
let element = new Gdome.element_of_node node in
let domName = Gdome.domString name in
if element#hasAttribute domName then
Some (element#getAttribute domName)#to_string
else
None
let apply
~(logger: Uwobo_logger.sysLogger)
~(styles: Uwobo_styles.styles)
~keys ~params ~props ~input =
(* "p_" prefix means "processed" *)
let (p_stylesheets, last_stylesheet) = styles#get keys in
logger#log `Debug (dump_args keys params props);
logger#log `Debug "Creating input document ...";
let result = (* Gdome.document *)
List.fold_left
(fun source (key, stylesheet) ->
logger#log `Debug (sprintf "Applying stylesheet %s ..." key);
try
let params =
List.map (fun (key,value) -> (key, "'" ^ value ^ "'")) (params key)
in
logger#log
`Debug
(sprintf
"Gdome_xslt.applyStylesheet params=%s"
(String.concat ", " (List.map (fun (k,v) -> k^": "^v) params)));
let res = Gdome_xslt.applyStylesheet ~source ~stylesheet ~params in
res
with e -> raise (Uwobo_failure (Printexc.to_string e)))
input
p_stylesheets
in
(* used to retrieve serialization options *)
let last_stylesheet =
try
apply_properties logger last_stylesheet props
with Unsupported_property prop ->
raise (Uwobo_failure (sprintf "Unsupported property: %s" prop))
in
let p_last_stylesheet = Gdome_xslt.processStylesheet last_stylesheet in
((fun outchan -> (* serialization function *)
Gdome_xslt.saveResultToChannel
~outchan
~result
~stylesheet:p_last_stylesheet),
(get_property "media-type" last_stylesheet), (* media-type *)
(get_property "encoding" last_stylesheet)) (* encoding *)