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 let apply
  93   ~(logger: Uwobo_logger.sysLogger)
  94   ~(styles: Uwobo_styles.styles)
  95   ~keys ~params ~props ~input
  96   =
  97     (* "p_" prefix means "processed" *)
  98   let (p_stylesheets, last_stylesheet) = styles#get keys in
  99   logger#log `Debug "Creating input document ...";
 100   let intermediate_results_seqno = ref 0 in
 101   let result = (* Gdome.document *)
 102     List.fold_left
 103       (fun source (key, stylesheet) ->
 104         logger#log `Debug (sprintf "Applying stylesheet %s ..." key);
 105         try
 106           let params =
 107             List.map (fun (key,value) -> (key, "'" ^ value ^ "'")) (params key)
 108           in
 109           logger#log `Debug
 110             (sprintf "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   let last_stylesheet = (* used to retrieve serialization options *)
 129     try
 130       apply_properties logger last_stylesheet props
 131     with Unsupported_property prop ->
 132       raise (Uwobo_failure (sprintf "Unsupported property: %s" prop))
 133   in
 134   let p_last_stylesheet = Gdome_xslt.processStylesheet last_stylesheet in
 135   ((fun outchan ->                              (* serialization function *)
 136       Gdome_xslt.saveResultToChannel ~outchan ~result
 137         ~stylesheet:p_last_stylesheet),
 138    (get_property "media-type" last_stylesheet), (* media-type *)
 139    (get_property "encoding" last_stylesheet))   (* encoding *)
 140