+++ /dev/null
-(*
- * Copyright (C) 2003:
- * Stefano Zacchiroli <zack@cs.unibo.it>
- * for the HELM Team http://helm.cs.unibo.it/
- *
- * 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://helm.cs.unibo.it/
- *)
-
-open Printf;;
-open Uwobo_common;;
-
- (** set this to true and uwobo will save transformation's intermediate results
- in /tmp/uwobo_intermediate_<seqno>_<pid>.xml *)
-let save_intermediate_results = false;;
-
-exception Unsupported_property of string;;
-
-let xslNS = Gdome.domString "http://www.w3.org/1999/XSL/Transform"
-let outputS = Gdome.domString "output"
-let q_outputS = Gdome.domString "xsl:output"
-
-let default_properties = [] (* no default properties *)
-
- (** apply an output property to an xslt stylesheet *)
-let apply_property logger (element: Gdome.element) (name, value) =
- if Uwobo_common.is_supported_property name then begin
- logger#log `Debug (sprintf "Setting property: %s = %s" name value);
- element#setAttribute (Gdome.domString name) (Gdome.domString value)
- end else
- raise (Unsupported_property name)
-
- (** 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.
- Before applying "props" properties applies a set of default properties as
- defined in "default_properties" *)
-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
- List.iter
- (apply_property logger (output_element :> Gdome.element))
- (default_properties @ 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 "Creating input document ...";
- let intermediate_results_seqno = ref 0 in
- 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
- if save_intermediate_results then begin
- let domImpl = Gdome.domImplementation () in
- ignore
- (domImpl#saveDocumentToFile
- ~doc:res
- ~name:(sprintf "/tmp/uwobo_intermediate_%d_%d.xml"
- !intermediate_results_seqno (Unix.getpid()))
- ());
- incr intermediate_results_seqno;
- end;
- res
- with e -> raise (Uwobo_failure (Printexc.to_string e)))
- input
- p_stylesheets
- in
- let last_stylesheet = (* used to retrieve serialization options *)
- 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 *)
-
projects / helm.git / blobdiff