+++ /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