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