helm/uwobo/uwobo_engine.ml

   1 (*
   2  * Copyright (C) 2003:
   3  *    Stefano Zacchiroli <zack@cs.unibo.it>
   4  *    for the HELM Team http://helm.cs.unibo.it/
   5  *
   6  *  This file is part of HELM, an Hypertextual, Electronic
   7  *  Library of Mathematics, developed at the Computer Science
   8  *  Department, University of Bologna, Italy.
   9  *
  10  *  HELM is free software; you can redistribute it and/or
  11  *  modify it under the terms of the GNU General Public License
  12  *  as published by the Free Software Foundation; either version 2
  13  *  of the License, or (at your option) any later version.
  14  *
  15  *  HELM is distributed in the hope that it will be useful,
  16  *  but WITHOUT ANY WARRANTY; without even the implied warranty of
  17  *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18  *  GNU General Public License for more details.
  19  *
  20  *  You should have received a copy of the GNU General Public License
  21  *  along with HELM; if not, write to the Free Software
  22  *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  23  *  MA  02111-1307, USA.
  24  *
  25  *  For details, see the HELM World-Wide-Web page,
  26  *  http://helm.cs.unibo.it/
  27  *)
  28
  29 open Printf;;
  30 open Uwobo_common;;
  31
  32   (** set this to true and uwobo will save transformation's intermediate results
  33   in /tmp/uwobo_intermediate_<seqno>_<pid>.xml *)
  34 let save_intermediate_results = false;;
  35
  36 let xslNS = Gdome.domString "http://www.w3.org/1999/XSL/Transform"
  37 let outputS = Gdome.domString "output"
  38
  39   (** given a Gdome.document representing an XSLT stylesheet and an output
  40   property return 'Some value' where 'value' is the property value, or None if
  41   it's not defined *)
  42 let get_property name (document: Gdome.document) =
  43   let node_list = document#getElementsByTagNameNS xslNS outputS in
  44   match node_list#item 0 with
  45   | None -> None
  46   | Some node ->
  47       let element = new Gdome.element_of_node node in
  48       let domName = Gdome.domString name in
  49       if element#hasAttribute domName then
  50         Some (element#getAttribute domName)#to_string
  51       else
  52         None
  53 ;;
  54
  55 let namespaceURI = Some (Gdome.domString Uwobo_common.uwobo_namespace) ;;
  56
  57   (** output type wrt adding of debugging/error messages *)
  58 type outputType =
  59   | XmlOutput of Gdome.node
  60   | TextPlainOutput of Gdome.text
  61   | NoOutput
  62 ;;
  63
  64 exception Found of int ;;
  65
  66   (** add debugging and/or error messages to a Gdome document. Handle three
  67   distinct cases: (1) output contains an XML tree, (2) output contains only one
  68   text node, (3) output contains no data.
  69   If output contains an XML tree then users wishes are preserved and messages
  70   are either not included or included as comments or included as XML ndoes.
  71   If output contains only a text node comments are either not included or
  72   included at the beginning of the textual output.
  73   If output contains no data (i.e. DOM superroot node with no element or text
  74   children) messages are embedded as XML comments or not embedded at all *)
  75 let add_msgs ~errormode ~debugmode ~msgs (doc: Gdome.document) =
  76   let getOutputType (doc: Gdome.document) =
  77     let children = doc#get_childNodes in
  78     let len = children#get_length in
  79     let rec find_element i =
  80       if i > len then
  81         raise Not_found
  82       else
  83         (match children#item i with
  84         | Some node when node#get_nodeType = GdomeNodeTypeT.ELEMENT_NODE ->
  85             XmlOutput node
  86         | _ -> find_element (i + 1))
  87     in
  88     let rec find_text i =
  89       if i > len then
  90         raise Not_found
  91       else
  92         (match children#item i with
  93         | Some node when node#get_nodeType = GdomeNodeTypeT.TEXT_NODE ->
  94             TextPlainOutput (new Gdome.text_of_node node)
  95         | _ -> find_element (i + 1))
  96     in
  97     if len = 0 then
  98       NoOutput
  99     else
 100       (try find_element 0 with Not_found ->
 101         (try find_text 0 with Not_found -> NoOutput))
 102   in
 103   match getOutputType (doc :> Gdome.document) with
 104   | XmlOutput node ->
 105     let add_generic_msg mode build tagname =
 106       (match mode with
 107       | LibXsltMsgIgnore -> (fun msg -> ())
 108       | LibXsltMsgComment ->
 109           (fun msg ->
 110 (*                 let contents = string_of_xslt_msg (build msg) ^ "<br />" in *)
 111             let contents = string_of_xslt_msg (build msg) in
 112             ignore (node#insertBefore
 113               ~newChild:(doc#createComment
 114                 (Gdome.domString contents) :> Gdome.node)
 115               ~refChild:node#get_firstChild))
 116       | LibXsltMsgEmbed ->
 117           (fun msg ->
 118 (*                 let contents = string_of_xslt_msg (build msg) ^ "<br />" in *)
 119             let contents = string_of_xslt_msg (build msg) in
 120             let element =
 121               doc#createElementNS
 122                 ~namespaceURI ~qualifiedName:(Gdome.domString tagname)
 123             in
 124             ignore (element#appendChild
 125               (doc#createTextNode
 126                 ~data:(Gdome.domString contents) :> Gdome.node));
 127             ignore (node#insertBefore
 128               ~newChild:(element :> Gdome.node)
 129               ~refChild:node#get_firstChild)))
 130     in
 131     let add_error_msg =
 132       add_generic_msg
 133         errormode (fun msg -> LibXsltErrorMsg msg) "uwobo:error"
 134     in
 135     let add_debug_msg =
 136       add_generic_msg
 137         debugmode (fun msg -> LibXsltDebugMsg msg) "uwobo:debug"
 138     in
 139     List.iter
 140       (function
 141         | LibXsltErrorMsg msg -> add_error_msg msg
 142         | LibXsltDebugMsg msg -> add_debug_msg msg)
 143       (List.rev msgs) (* because each msg is added as 1st children *)
 144 | TextPlainOutput text ->
 145     let add_generic_msg mode build =
 146       (match mode with
 147       | LibXsltMsgIgnore -> (fun _ -> ())
 148       | LibXsltMsgComment | LibXsltMsgEmbed ->
 149           (fun msg ->
 150             text#insertData ~offset:0
 151               ~arg:(Gdome.domString
 152                 (string_of_xslt_msg (build msg) ^ "\n"))))
 153     in
 154     let add_error_msg =
 155       add_generic_msg errormode (fun msg -> LibXsltErrorMsg msg)
 156     in
 157     let add_debug_msg =
 158       add_generic_msg debugmode (fun msg -> LibXsltDebugMsg msg)
 159     in
 160     List.iter
 161       (function
 162         | LibXsltErrorMsg msg -> add_error_msg msg
 163         | LibXsltDebugMsg msg -> add_debug_msg msg)
 164       (List.rev msgs) (* because each msg is added as 1st children *)
 165 | NoOutput ->
 166     let add_generic_msg mode build =
 167       (match mode with
 168       | LibXsltMsgIgnore -> (fun _ -> ())
 169       | LibXsltMsgComment | LibXsltMsgEmbed ->
 170           (fun msg ->
 171             let comment_node =
 172               (* use comments anyway because text nodes aren't allowed in DOM as
 173               superroot children *)
 174               doc#createComment
 175                 (Gdome.domString (string_of_xslt_msg (build msg)))
 176             in
 177             ignore (doc#insertBefore ~newChild:(comment_node :> Gdome.node)
 178               ~refChild:doc#get_firstChild)))
 179     in
 180     let add_error_msg =
 181       add_generic_msg errormode (fun msg -> LibXsltErrorMsg msg)
 182     in
 183     let add_debug_msg =
 184       add_generic_msg debugmode (fun msg -> LibXsltDebugMsg msg)
 185     in
 186     List.iter
 187       (function
 188         | LibXsltErrorMsg msg -> add_error_msg msg
 189         | LibXsltDebugMsg msg -> add_debug_msg msg)
 190       (List.rev msgs) (* because each msg is added as 1st children *)
 191 ;;
 192
 193 let apply
 194   ~(logger: Uwobo_logger.sysLogger)
 195   ~(styles: Uwobo_styles.styles)
 196   ~keys ~params ~props
 197   ~(veillogger: Uwobo_common.libXsltLogger)
 198   ?(errormode = LibXsltMsgIgnore) ?(debugmode = LibXsltMsgIgnore)
 199   input
 200   =
 201     (* "p_" prefix means "processed" *)
 202   let (p_stylesheets,last_stylesheet) = styles#get keys props logger in
 203   logger#log `Debug "Creating input document ...";
 204   let intermediate_results_seqno = ref 0 in
 205   let result = (* Gdome.document *)
 206     List.fold_left
 207       (fun source (key, stylesheet) ->
 208         logger#log `Debug (sprintf "Applying stylesheet %s ..." key);
 209         try
 210           let params =
 211             List.map
 212              (fun (key,value) ->
 213                let quoted_value =
 214                 if String.contains value '\'' then
 215                  if String.contains value '"' then
 216                   raise
 217                    (Failure
 218                      ("A parameter value can not contain both single and " ^
 219                       "double quotes, since it must be a valid XPath string " ^
 220                       "literal"))
 221                  else
 222                   "\"" ^ value ^ "\""
 223                 else
 224                  "'" ^ value ^ "'"
 225                in
 226                 (key,quoted_value)
 227              ) (params key)
 228           in
 229           logger#log `Debug
 230             (sprintf "Gdome_xslt.applyStylesheet params=%s"
 231               (String.concat ", " (List.map (fun (k,v) -> k^": "^v) params)));
 232           let res = Gdome_xslt.applyStylesheet ~source ~stylesheet ~params in
 233           if save_intermediate_results then begin
 234             let domImpl = Gdome.domImplementation () in
 235             ignore
 236               (domImpl#saveDocumentToFile
 237                 ~doc:res
 238                 ~name:(sprintf "/tmp/uwobo_intermediate_%d_%d.xml"
 239                   !intermediate_results_seqno (Unix.getpid()))
 240                 ());
 241             incr intermediate_results_seqno;
 242           end;
 243           res
 244         with e -> raise (Uwobo_failure (Printexc.to_string e)))
 245       input
 246       p_stylesheets
 247   in
 248     (* add error and debugging messages to result document *)
 249   add_msgs ~errormode ~debugmode ~msgs:veillogger#msgs result;
 250 (*
 251   (* DEBUGGING *)
 252   add_msgs
 253     ~errormode:LibXsltMsgEmbed ~debugmode:LibXsltMsgEmbed
 254     ~msgs:[LibXsltErrorMsg "error1"; LibXsltDebugMsg "debug1"]
 255     result;
 256 *)
 257   let p_last_stylesheet = snd (List.hd (List.rev p_stylesheets)) in
 258   ((fun outchan ->                              (* serialization function *)
 259       Gdome_xslt.saveResultToChannel ~outchan ~result
 260         ~stylesheet:p_last_stylesheet),
 261    (get_property "media-type" last_stylesheet), (* media-type *)
 262    (get_property "encoding" last_stylesheet))   (* encoding *)
 263