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 exception Unsupported_property of string;;
  37
  38 let xslNS = Gdome.domString "http://www.w3.org/1999/XSL/Transform"
  39 let outputS = Gdome.domString "output"
  40 let q_outputS = Gdome.domString "xsl:output"
  41
  42 let default_properties = [] (* no default properties *)
  43
  44   (** apply an output property to an xslt stylesheet *)
  45 let apply_property logger (element: Gdome.element) (name, value) =
  46   if Uwobo_common.is_supported_property name then begin
  47     logger#log `Debug (sprintf "Setting property: %s = %s" name value);
  48     element#setAttribute (Gdome.domString name) (Gdome.domString value)
  49   end else
  50     raise (Unsupported_property name)
  51
  52   (** set a list of output properties in an xslt stylesheet, return a copy of
  53   the given stylesheet modified as needed, given stylesheet wont be changed by
  54   this operation.
  55   Before applying "props" properties applies a set of default properties as
  56   defined in "default_properties" *)
  57 let apply_properties logger last_stylesheet props =
  58   let last_stylesheet =
  59     new Gdome.document_of_node (last_stylesheet#cloneNode ~deep:true)
  60   in
  61   let output_element =
  62     let node_list = last_stylesheet#getElementsByTagNameNS xslNS outputS in
  63     (match node_list#item 0 with
  64     | None -> (* no xsl:output element, create it from scratch *)
  65         logger#log `Debug "Creating xsl:output node ...";
  66         let elt = last_stylesheet#createElementNS (Some xslNS) q_outputS in
  67         let root = last_stylesheet#get_documentElement in
  68         ignore (root#appendChild (elt :> Gdome.node));
  69         elt
  70     | Some node -> new Gdome.element_of_node node)
  71   in
  72   List.iter
  73     (apply_property logger (output_element :> Gdome.element))
  74     (default_properties @ props);
  75   last_stylesheet
  76
  77   (** given a Gdome.document representing an XSLT stylesheet and an output
  78   property return 'Some value' where 'value' is the property value, or None if
  79   it's not defined *)
  80 let get_property name (document: Gdome.document) =
  81   let node_list = document#getElementsByTagNameNS xslNS outputS in
  82   match node_list#item 0 with
  83   | None -> None
  84   | Some node ->
  85       let element = new Gdome.element_of_node node in
  86       let domName = Gdome.domString name in
  87       if element#hasAttribute domName then
  88         Some (element#getAttribute domName)#to_string
  89       else
  90         None
  91 ;;
  92
  93 let namespaceURI = Some (Gdome.domString Uwobo_common.uwobo_namespace) ;;
  94
  95   (** output type wrt adding of debugging/error messages *)
  96 type outputType =
  97   | XmlOutput of Gdome.node
  98   | TextPlainOutput of Gdome.text
  99   | NoOutput
 100 ;;
 101
 102 exception Found of int ;;
 103
 104   (** add debugging and/or error messages to a Gdome document. Handle three
 105   distinct cases: (1) output contains an XML tree, (2) output contains only one
 106   text node, (3) output contains no data.
 107   If output contains an XML tree then users wishes are preserved and messages
 108   are either not included or included as comments or included as XML ndoes.
 109   If output contains only a text node comments are either not included or
 110   included at the beginning of the textual output.
 111   If output contains no data (i.e. DOM superroot node with no element or text
 112   children) messages are embedded as XML comments or not embedded at all *)
 113 let add_msgs ~errormode ~debugmode ~msgs (doc: Gdome.document) =
 114   let getOutputType (doc: Gdome.document) =
 115     let children = doc#get_childNodes in
 116     let len = children#get_length in
 117     let rec find_element i =
 118       if i > len then
 119         raise Not_found
 120       else
 121         (match children#item i with
 122         | Some node when node#get_nodeType = GdomeNodeTypeT.ELEMENT_NODE ->
 123             XmlOutput node
 124         | _ -> find_element (i + 1))
 125     in
 126     let rec find_text i =
 127       if i > len then
 128         raise Not_found
 129       else
 130         (match children#item i with
 131         | Some node when node#get_nodeType = GdomeNodeTypeT.TEXT_NODE ->
 132             TextPlainOutput (new Gdome.text_of_node node)
 133         | _ -> find_element (i + 1))
 134     in
 135     if len = 0 then
 136       NoOutput
 137     else
 138       (try find_element 0 with Not_found ->
 139         (try find_text 0 with Not_found -> NoOutput))
 140   in
 141   match getOutputType (doc :> Gdome.document) with
 142   | XmlOutput node ->
 143     let add_generic_msg mode build tagname =
 144       (match mode with
 145       | LibXsltMsgIgnore -> (fun msg -> ())
 146       | LibXsltMsgComment ->
 147           (fun msg ->
 148 (*                 let contents = string_of_xslt_msg (build msg) ^ "<br />" in *)
 149             let contents = string_of_xslt_msg (build msg) in
 150             ignore (node#insertBefore
 151               ~newChild:(doc#createComment
 152                 (Gdome.domString contents) :> Gdome.node)
 153               ~refChild:node#get_firstChild))
 154       | LibXsltMsgEmbed ->
 155           (fun msg ->
 156 (*                 let contents = string_of_xslt_msg (build msg) ^ "<br />" in *)
 157             let contents = string_of_xslt_msg (build msg) in
 158             let element =
 159               doc#createElementNS
 160                 ~namespaceURI ~qualifiedName:(Gdome.domString tagname)
 161             in
 162             ignore (element#appendChild
 163               (doc#createTextNode
 164                 ~data:(Gdome.domString contents) :> Gdome.node));
 165             ignore (node#insertBefore
 166               ~newChild:(element :> Gdome.node)
 167               ~refChild:node#get_firstChild)))
 168     in
 169     let add_error_msg =
 170       add_generic_msg
 171         errormode (fun msg -> LibXsltErrorMsg msg) "uwobo:error"
 172     in
 173     let add_debug_msg =
 174       add_generic_msg
 175         debugmode (fun msg -> LibXsltDebugMsg msg) "uwobo:debug"
 176     in
 177     List.iter
 178       (function
 179         | LibXsltErrorMsg msg -> add_error_msg msg
 180         | LibXsltDebugMsg msg -> add_debug_msg msg)
 181       (List.rev msgs) (* because each msg is added as 1st children *)
 182 | TextPlainOutput text ->
 183     let add_generic_msg mode build =
 184       (match mode with
 185       | LibXsltMsgIgnore -> (fun _ -> ())
 186       | LibXsltMsgComment | LibXsltMsgEmbed ->
 187           (fun msg ->
 188             text#insertData ~offset:0
 189               ~arg:(Gdome.domString
 190                 (string_of_xslt_msg (build msg) ^ "\n"))))
 191     in
 192     let add_error_msg =
 193       add_generic_msg errormode (fun msg -> LibXsltErrorMsg msg)
 194     in
 195     let add_debug_msg =
 196       add_generic_msg debugmode (fun msg -> LibXsltDebugMsg msg)
 197     in
 198     List.iter
 199       (function
 200         | LibXsltErrorMsg msg -> add_error_msg msg
 201         | LibXsltDebugMsg msg -> add_debug_msg msg)
 202       (List.rev msgs) (* because each msg is added as 1st children *)
 203 | NoOutput ->
 204     let add_generic_msg mode build =
 205       (match mode with
 206       | LibXsltMsgIgnore -> (fun _ -> ())
 207       | LibXsltMsgComment | LibXsltMsgEmbed ->
 208           (fun msg ->
 209             let comment_node =
 210               (* use comments anyway because text nodes aren't allowed in DOM as
 211               superroot children *)
 212               doc#createComment
 213                 (Gdome.domString (string_of_xslt_msg (build msg)))
 214             in
 215             ignore (doc#insertBefore ~newChild:(comment_node :> Gdome.node)
 216               ~refChild:doc#get_firstChild)))
 217     in
 218     let add_error_msg =
 219       add_generic_msg errormode (fun msg -> LibXsltErrorMsg msg)
 220     in
 221     let add_debug_msg =
 222       add_generic_msg debugmode (fun msg -> LibXsltDebugMsg msg)
 223     in
 224     List.iter
 225       (function
 226         | LibXsltErrorMsg msg -> add_error_msg msg
 227         | LibXsltDebugMsg msg -> add_debug_msg msg)
 228       (List.rev msgs) (* because each msg is added as 1st children *)
 229 ;;
 230
 231 let apply
 232   ~(logger: Uwobo_logger.sysLogger)
 233   ~(styles: Uwobo_styles.styles)
 234   ~keys ~params ~props
 235   ~(veillogger: Uwobo_common.libXsltLogger)
 236   ?(errormode = LibXsltMsgIgnore) ?(debugmode = LibXsltMsgIgnore)
 237   input
 238   =
 239     (* "p_" prefix means "processed" *)
 240   let (p_stylesheets, last_stylesheet) = styles#get keys in
 241   logger#log `Debug "Creating input document ...";
 242   let intermediate_results_seqno = ref 0 in
 243   let result = (* Gdome.document *)
 244     List.fold_left
 245       (fun source (key, stylesheet) ->
 246         logger#log `Debug (sprintf "Applying stylesheet %s ..." key);
 247         try
 248           let params =
 249             List.map (fun (key,value) -> (key, "'" ^ value ^ "'")) (params key)
 250           in
 251           logger#log `Debug
 252             (sprintf "Gdome_xslt.applyStylesheet params=%s"
 253               (String.concat ", " (List.map (fun (k,v) -> k^": "^v) params)));
 254           let res = Gdome_xslt.applyStylesheet ~source ~stylesheet ~params in
 255           if save_intermediate_results then begin
 256             let domImpl = Gdome.domImplementation () in
 257             ignore
 258               (domImpl#saveDocumentToFile
 259                 ~doc:res
 260                 ~name:(sprintf "/tmp/uwobo_intermediate_%d_%d.xml"
 261                   !intermediate_results_seqno (Unix.getpid()))
 262                 ());
 263             incr intermediate_results_seqno;
 264           end;
 265           res
 266         with e -> raise (Uwobo_failure (Printexc.to_string e)))
 267       input
 268       p_stylesheets
 269   in
 270     (* add error and debugging messages to result document *)
 271   add_msgs ~errormode ~debugmode ~msgs:veillogger#msgs result;
 272 (*
 273   (* DEBUGGING *)
 274   add_msgs
 275     ~errormode:LibXsltMsgEmbed ~debugmode:LibXsltMsgEmbed
 276     ~msgs:[LibXsltErrorMsg "error1"; LibXsltDebugMsg "debug1"]
 277     result;
 278 *)
 279   let last_stylesheet = (* used to retrieve serialization options *)
 280     try
 281       apply_properties logger last_stylesheet props
 282     with Unsupported_property prop ->
 283       raise (Uwobo_failure (sprintf "Unsupported property: %s" prop))
 284   in
 285   let p_last_stylesheet = Gdome_xslt.processStylesheet last_stylesheet in
 286   ((fun outchan ->                              (* serialization function *)
 287       Gdome_xslt.saveResultToChannel ~outchan ~result
 288         ~stylesheet:p_last_stylesheet),
 289    (get_property "media-type" last_stylesheet), (* media-type *)
 290    (get_property "encoding" last_stylesheet))   (* encoding *)
 291