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   (** set a list of output properties in an xslt stylesheet, return a copy of
  41   the given stylesheet modified as needed, given stylesheet wont be changed by
  42   this operation *)
  43 let apply_properties logger last_stylesheet props =
  44   let last_stylesheet =
  45     new Gdome.document_of_node (last_stylesheet#cloneNode ~deep:true)
  46   in
  47   let output_element =
  48     let node_list = last_stylesheet#getElementsByTagNameNS xslNS outputS in
  49     (match node_list#item 0 with
  50     | None -> (* no xsl:output element, create it from scratch *)
  51         logger#log `Debug "Creating xsl:output node ...";
  52         let elt = last_stylesheet#createElementNS (Some xslNS) q_outputS in
  53         let root = last_stylesheet#get_documentElement in
  54         ignore (root#appendChild (elt :> Gdome.node));
  55         elt
  56     | Some node -> new Gdome.element_of_node node)
  57   in
  58   let apply_property (name, value) =
  59     if Uwobo_common.is_supported_property name then begin
  60         logger#log `Debug (sprintf "Setting property: %s = %s" name value);
  61         output_element#setAttribute
  62           (Gdome.domString name)
  63           (Gdome.domString value)
  64       end
  65     else
  66       raise (Unsupported_property name)
  67   in
  68   List.iter apply_property props;
  69   last_stylesheet
  70
  71   (** given a Gdome.document representing an XSLT stylesheet and an output
  72   property return 'Some value' where 'value' is the property value, or None if
  73   it's not defined *)
  74 let get_property name (document: Gdome.document) =
  75   let node_list = document#getElementsByTagNameNS xslNS outputS in
  76   match node_list#item 0 with
  77   | None -> None
  78   | Some node ->
  79       let element = new Gdome.element_of_node node in
  80       let domName = Gdome.domString name in
  81       if element#hasAttribute domName then
  82         Some (element#getAttribute domName)#to_string
  83       else
  84         None
  85
  86 let apply
  87   ~(logger: Uwobo_logger.sysLogger)
  88   ~(styles: Uwobo_styles.styles)
  89   ~keys ~params ~props ~input =
  90     (* "p_" prefix means "processed" *)
  91   let (p_stylesheets, last_stylesheet) = styles#get keys in
  92   logger#log `Debug "Creating input document ...";
  93   let intermediate_results_seqno = ref 0 in
  94   let result = (* Gdome.document *)
  95     List.fold_left
  96       (fun source (key, stylesheet) ->
  97         logger#log `Debug (sprintf "Applying stylesheet %s ..." key);
  98         try
  99           let params =
 100             List.map (fun (key,value) -> (key, "'" ^ value ^ "'")) (params key)
 101           in
 102           logger#log
 103             `Debug
 104             (sprintf
 105               "Gdome_xslt.applyStylesheet params=%s"
 106               (String.concat ", " (List.map (fun (k,v) -> k^": "^v) params)));
 107           let res = Gdome_xslt.applyStylesheet ~source ~stylesheet ~params in
 108           if save_intermediate_results then begin
 109             let domImpl = Gdome.domImplementation () in
 110             ignore
 111               (domImpl#saveDocumentToFile
 112                 ~doc:res
 113                 ~name:(sprintf "/tmp/uwobo_intermediate_%d_%d.xml"
 114                   !intermediate_results_seqno (Unix.getpid()))
 115                 ());
 116             incr intermediate_results_seqno;
 117           end;
 118           res
 119         with e -> raise (Uwobo_failure (Printexc.to_string e)))
 120       input
 121       p_stylesheets
 122   in
 123     (* used to retrieve serialization options *)
 124   let last_stylesheet =
 125     try
 126       apply_properties logger last_stylesheet props
 127     with Unsupported_property prop ->
 128       raise (Uwobo_failure (sprintf "Unsupported property: %s" prop))
 129   in
 130   let p_last_stylesheet = Gdome_xslt.processStylesheet last_stylesheet in
 131   ((fun outchan ->                              (* serialization function *)
 132       Gdome_xslt.saveResultToChannel
 133         ~outchan
 134         ~result
 135         ~stylesheet:p_last_stylesheet),
 136    (get_property "media-type" last_stylesheet), (* media-type *)
 137    (get_property "encoding" last_stylesheet))   (* encoding *)
 138