helm/uwobo/src/ocaml/uwobo_engine.ml

   1
   2 (* Copyright (C) 2002, HELM Team.
   3  *
   4  * This file is part of HELM, an Hypertextual, Electronic
   5  * Library of Mathematics, developed at the Computer Science
   6  * Department, University of Bologna, Italy.
   7  *
   8  * HELM is free software; you can redistribute it and/or
   9  * modify it under the terms of the GNU General Public License
  10  * as published by the Free Software Foundation; either version 2
  11  * of the License, or (at your option) any later version.
  12  *
  13  * HELM is distributed in the hope that it will be useful,
  14  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  15  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16  * GNU General Public License for more details.
  17  *
  18  * You should have received a copy of the GNU General Public License
  19  * along with HELM; if not, write to the Free Software
  20  * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  21  * MA  02111-1307, USA.
  22  *
  23  * For details, see the HELM World-Wide-Web page,
  24  * http://cs.unibo.it/helm/.
  25  *)
  26
  27 open Printf;;
  28 open Uwobo_common;;
  29
  30   (** set this to true and uwobo will save transformation's intermediate results
  31   in /tmp/uwobo_intermediate_<seqno>_<pid>.xml *)
  32 let save_intermediate_results = false;;
  33
  34 exception Unsupported_property of string;;
  35
  36 let xslNS = Gdome.domString "http://www.w3.org/1999/XSL/Transform"
  37 let outputS = Gdome.domString "output"
  38 let q_outputS = Gdome.domString "xsl:output"
  39
  40 let default_properties = [ "method", "xml" ]
  41
  42   (** apply an output property to an xslt stylesheet *)
  43 let apply_property logger (element: Gdome.element) (name, value) =
  44   if Uwobo_common.is_supported_property name then begin
  45       logger#log `Debug (sprintf "Setting property: %s = %s" name value);
  46       element#setAttribute (Gdome.domString name) (Gdome.domString value)
  47     end
  48   else
  49     raise (Unsupported_property name)
  50
  51   (** set a list of output properties in an xslt stylesheet, return a copy of
  52   the given stylesheet modified as needed, given stylesheet wont be changed by
  53   this operation.
  54   Before applying "props" properties applies a set of default properties as
  55   defined in "default_properties" *)
  56 let apply_properties logger last_stylesheet props =
  57   let last_stylesheet =
  58     new Gdome.document_of_node (last_stylesheet#cloneNode ~deep:true)
  59   in
  60   let output_element =
  61     let node_list = last_stylesheet#getElementsByTagNameNS xslNS outputS in
  62     (match node_list#item 0 with
  63     | None -> (* no xsl:output element, create it from scratch *)
  64         logger#log `Debug "Creating xsl:output node ...";
  65         let elt = last_stylesheet#createElementNS (Some xslNS) q_outputS in
  66         let root = last_stylesheet#get_documentElement in
  67         ignore (root#appendChild (elt :> Gdome.node));
  68         elt
  69     | Some node -> new Gdome.element_of_node node)
  70   in
  71   List.iter
  72     (apply_property logger (output_element :> Gdome.element))
  73     (default_properties @ props);
  74   last_stylesheet
  75
  76   (** given a Gdome.document representing an XSLT stylesheet and an output
  77   property return 'Some value' where 'value' is the property value, or None if
  78   it's not defined *)
  79 let get_property name (document: Gdome.document) =
  80   let node_list = document#getElementsByTagNameNS xslNS outputS in
  81   match node_list#item 0 with
  82   | None -> None
  83   | Some node ->
  84       let element = new Gdome.element_of_node node in
  85       let domName = Gdome.domString name in
  86       if element#hasAttribute domName then
  87         Some (element#getAttribute domName)#to_string
  88       else
  89         None
  90
  91 let apply
  92   ~(logger: Uwobo_logger.sysLogger)
  93   ~(styles: Uwobo_styles.styles)
  94   ~keys ~params ~props ~input =
  95     (* "p_" prefix means "processed" *)
  96   let (p_stylesheets, last_stylesheet) = styles#get keys in
  97   logger#log `Debug "Creating input document ...";
  98   let intermediate_results_seqno = ref 0 in
  99   let result = (* Gdome.document *)
 100     List.fold_left
 101       (fun source (key, stylesheet) ->
 102         logger#log `Debug (sprintf "Applying stylesheet %s ..." key);
 103         try
 104           let params =
 105             List.map (fun (key,value) -> (key, "'" ^ value ^ "'")) (params key)
 106           in
 107           logger#log
 108             `Debug
 109             (sprintf
 110               "Gdome_xslt.applyStylesheet params=%s"
 111               (String.concat ", " (List.map (fun (k,v) -> k^": "^v) params)));
 112           let res = Gdome_xslt.applyStylesheet ~source ~stylesheet ~params in
 113           if save_intermediate_results then begin
 114             let domImpl = Gdome.domImplementation () in
 115             ignore
 116               (domImpl#saveDocumentToFile
 117                 ~doc:res
 118                 ~name:(sprintf "/tmp/uwobo_intermediate_%d_%d.xml"
 119                   !intermediate_results_seqno (Unix.getpid()))
 120                 ());
 121             incr intermediate_results_seqno;
 122           end;
 123           res
 124         with e -> raise (Uwobo_failure (Printexc.to_string e)))
 125       input
 126       p_stylesheets
 127   in
 128     (* used to retrieve serialization options *)
 129   let last_stylesheet =
 130     try
 131       apply_properties logger last_stylesheet props
 132     with Unsupported_property prop ->
 133       raise (Uwobo_failure (sprintf "Unsupported property: %s" prop))
 134   in
 135   let p_last_stylesheet = Gdome_xslt.processStylesheet last_stylesheet in
 136   ((fun outchan ->                              (* serialization function *)
 137       Gdome_xslt.saveResultToChannel
 138         ~outchan
 139         ~result
 140         ~stylesheet:p_last_stylesheet),
 141    (get_property "media-type" last_stylesheet), (* media-type *)
 142    (get_property "encoding" last_stylesheet))   (* encoding *)
 143