--- /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;;
+
+let xslNS = Gdome.domString "http://www.w3.org/1999/XSL/Transform"
+let outputS = Gdome.domString "output"
+
+ (** 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 namespaceURI = Some (Gdome.domString Uwobo_common.uwobo_namespace) ;;
+
+ (** output type wrt adding of debugging/error messages *)
+type outputType =
+ | XmlOutput of Gdome.node
+ | TextPlainOutput of Gdome.text
+ | NoOutput
+;;
+
+exception Found of int ;;
+
+ (** add debugging and/or error messages to a Gdome document. Handle three
+ distinct cases: (1) output contains an XML tree, (2) output contains only one
+ text node, (3) output contains no data.
+ If output contains an XML tree then users wishes are preserved and messages
+ are either not included or included as comments or included as XML ndoes.
+ If output contains only a text node comments are either not included or
+ included at the beginning of the textual output.
+ If output contains no data (i.e. DOM superroot node with no element or text
+ children) messages are embedded as XML comments or not embedded at all *)
+let add_msgs ~errormode ~debugmode ~msgs (doc: Gdome.document) =
+ let getOutputType (doc: Gdome.document) =
+ let children = doc#get_childNodes in
+ let len = children#get_length in
+ let rec find_element i =
+ if i > len then
+ raise Not_found
+ else
+ (match children#item i with
+ | Some node when node#get_nodeType = GdomeNodeTypeT.ELEMENT_NODE ->
+ XmlOutput node
+ | _ -> find_element (i + 1))
+ in
+ let rec find_text i =
+ if i > len then
+ raise Not_found
+ else
+ (match children#item i with
+ | Some node when node#get_nodeType = GdomeNodeTypeT.TEXT_NODE ->
+ TextPlainOutput (new Gdome.text_of_node node)
+ | _ -> find_element (i + 1))
+ in
+ if len = 0 then
+ NoOutput
+ else
+ (try find_element 0 with Not_found ->
+ (try find_text 0 with Not_found -> NoOutput))
+ in
+ match getOutputType (doc :> Gdome.document) with
+ | XmlOutput node ->
+ let add_generic_msg mode build tagname =
+ (match mode with
+ | LibXsltMsgIgnore -> (fun msg -> ())
+ | LibXsltMsgComment ->
+ (fun msg ->
+(* let contents = string_of_xslt_msg (build msg) ^ "<br />" in *)
+ let contents = string_of_xslt_msg (build msg) in
+ ignore (node#insertBefore
+ ~newChild:(doc#createComment
+ (Gdome.domString contents) :> Gdome.node)
+ ~refChild:node#get_firstChild))
+ | LibXsltMsgEmbed ->
+ (fun msg ->
+(* let contents = string_of_xslt_msg (build msg) ^ "<br />" in *)
+ let contents = string_of_xslt_msg (build msg) in
+ let element =
+ doc#createElementNS
+ ~namespaceURI ~qualifiedName:(Gdome.domString tagname)
+ in
+ ignore (element#appendChild
+ (doc#createTextNode
+ ~data:(Gdome.domString contents) :> Gdome.node));
+ ignore (node#insertBefore
+ ~newChild:(element :> Gdome.node)
+ ~refChild:node#get_firstChild)))
+ in
+ let add_error_msg =
+ add_generic_msg
+ errormode (fun msg -> LibXsltErrorMsg msg) "uwobo:error"
+ in
+ let add_debug_msg =
+ add_generic_msg
+ debugmode (fun msg -> LibXsltDebugMsg msg) "uwobo:debug"
+ in
+ List.iter
+ (function
+ | LibXsltErrorMsg msg -> add_error_msg msg
+ | LibXsltDebugMsg msg -> add_debug_msg msg)
+ (List.rev msgs) (* because each msg is added as 1st children *)
+| TextPlainOutput text ->
+ let add_generic_msg mode build =
+ (match mode with
+ | LibXsltMsgIgnore -> (fun _ -> ())
+ | LibXsltMsgComment | LibXsltMsgEmbed ->
+ (fun msg ->
+ text#insertData ~offset:0
+ ~arg:(Gdome.domString
+ (string_of_xslt_msg (build msg) ^ "\n"))))
+ in
+ let add_error_msg =
+ add_generic_msg errormode (fun msg -> LibXsltErrorMsg msg)
+ in
+ let add_debug_msg =
+ add_generic_msg debugmode (fun msg -> LibXsltDebugMsg msg)
+ in
+ List.iter
+ (function
+ | LibXsltErrorMsg msg -> add_error_msg msg
+ | LibXsltDebugMsg msg -> add_debug_msg msg)
+ (List.rev msgs) (* because each msg is added as 1st children *)
+| NoOutput ->
+ let add_generic_msg mode build =
+ (match mode with
+ | LibXsltMsgIgnore -> (fun _ -> ())
+ | LibXsltMsgComment | LibXsltMsgEmbed ->
+ (fun msg ->
+ let comment_node =
+ (* use comments anyway because text nodes aren't allowed in DOM as
+ superroot children *)
+ doc#createComment
+ (Gdome.domString (string_of_xslt_msg (build msg)))
+ in
+ ignore (doc#insertBefore ~newChild:(comment_node :> Gdome.node)
+ ~refChild:doc#get_firstChild)))
+ in
+ let add_error_msg =
+ add_generic_msg errormode (fun msg -> LibXsltErrorMsg msg)
+ in
+ let add_debug_msg =
+ add_generic_msg debugmode (fun msg -> LibXsltDebugMsg msg)
+ in
+ List.iter
+ (function
+ | LibXsltErrorMsg msg -> add_error_msg msg
+ | LibXsltDebugMsg msg -> add_debug_msg msg)
+ (List.rev msgs) (* because each msg is added as 1st children *)
+;;
+
+let apply
+ ~(logger: Uwobo_logger.sysLogger)
+ ~(styles: Uwobo_styles.styles)
+ ~keys ~params ~props
+ ~(veillogger: Uwobo_common.libXsltLogger)
+ ?(errormode = LibXsltMsgIgnore) ?(debugmode = LibXsltMsgIgnore)
+ input
+ =
+ (* "p_" prefix means "processed" *)
+ let (p_stylesheets,last_stylesheet) = styles#get keys props logger 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) ->
+ let quoted_value =
+ if String.contains value '\'' then
+ if String.contains value '"' then
+ raise
+ (Failure
+ ("A parameter value can not contain both single and " ^
+ "double quotes, since it must be a valid XPath string " ^
+ "literal"))
+ else
+ "\"" ^ value ^ "\""
+ else
+ "'" ^ value ^ "'"
+ in
+ (key,quoted_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
+ (* add error and debugging messages to result document *)
+ add_msgs ~errormode ~debugmode ~msgs:veillogger#msgs result;
+(*
+ (* DEBUGGING *)
+ add_msgs
+ ~errormode:LibXsltMsgEmbed ~debugmode:LibXsltMsgEmbed
+ ~msgs:[LibXsltErrorMsg "error1"; LibXsltDebugMsg "debug1"]
+ result;
+*)
+ let p_last_stylesheet = snd (List.hd (List.rev p_stylesheets)) 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