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 supported_properties = [
  33   "cdata-section-elements";
  34   "doctype-public";
  35   "doctype-system";
  36   "encoding";
  37   "indent";
  38   "media-type";
  39   "method";
  40   "omit-xml-declaration";
  41   "standalone";
  42   "version"
  43 ]
  44
  45 let dump_args keys params props =
  46   (sprintf "
  47 Keys: %s<br />
  48 Parameters:<br />
  49 %s
  50 Props: %s<br />
  51 "
  52     (String.concat ", " keys)
  53     (String.concat
  54       "<br />\n"
  55       (List.map
  56         (fun key ->
  57           (sprintf
  58             "Key: %s, Params: %s"
  59             key
  60             (String.concat
  61               ", "
  62               (List.map
  63                 (fun (key,value) -> sprintf "%s:%s" key value)
  64                 (params key)))))
  65         keys))
  66     (String.concat
  67       ", "
  68       (List.map (fun (key,value) -> sprintf "%s:%s" key value) props)))
  69
  70 let xslNS = Gdome.domString "http://www.w3.org/1999/XSL/Transform"
  71 let outputS = Gdome.domString "output"
  72 let q_outputS = Gdome.domString "xsl:output"
  73 let is_supported_property name = List.mem name supported_properties
  74
  75   (** set a list of output properties in an xslt stylesheet, return a copy of
  76   the given stylesheet modified as needed, given stylesheet wont be changed by
  77   this operation *)
  78 let apply_properties logger last_stylesheet props =
  79   let last_stylesheet =
  80     new Gdome.document_of_node (last_stylesheet#cloneNode ~deep:true)
  81   in
  82   let output_element =
  83     let node_list = last_stylesheet#getElementsByTagNameNS xslNS outputS in
  84     (match node_list#item 0 with
  85     | None -> (* no xsl:output element, create it from scratch *)
  86         logger#log `Debug "Creating xsl:output node ...";
  87         let elt = last_stylesheet#createElementNS (Some xslNS) q_outputS in
  88         let root = last_stylesheet#get_documentElement in
  89         ignore (root#appendChild (elt :> Gdome.node));
  90         elt
  91     | Some node -> new Gdome.element_of_node node)
  92   in
  93   let apply_property (name, value) =
  94     if is_supported_property name then begin
  95         logger#log `Debug (sprintf "Setting property: %s = %s" name value);
  96         output_element#setAttribute
  97           (Gdome.domString name)
  98           (Gdome.domString value)
  99       end
 100     else
 101       raise (Unsupported_property name)
 102   in
 103   List.iter apply_property props;
 104   last_stylesheet
 105
 106   (** given a Gdome.document representing an XSLT stylesheet and an output
 107   property return 'Some value' where 'value' is the property value, or None if
 108   it's not defined *)
 109 let get_property name (document: Gdome.document) =
 110   let node_list = document#getElementsByTagNameNS xslNS outputS in
 111   match node_list#item 0 with
 112   | None -> None
 113   | Some node ->
 114       let element = new Gdome.element_of_node node in
 115       let domName = Gdome.domString name in
 116       if element#hasAttribute domName then
 117         Some (element#getAttribute domName)#to_string
 118       else
 119         None
 120
 121 let apply
 122   ~(logger: Uwobo_logger.sysLogger)
 123   ~(styles: Uwobo_styles.styles)
 124   ~keys ~params ~props ~input =
 125     (* "p_" prefix means "processed" *)
 126   let (p_stylesheets, last_stylesheet) = styles#get keys in
 127   logger#log `Debug (dump_args keys params props);
 128   logger#log `Debug "Creating input document ...";
 129   let result = (* Gdome.document *)
 130     List.fold_left
 131       (fun source (key, stylesheet) ->
 132         logger#log `Debug (sprintf "Applying stylesheet %s ..." key);
 133         try
 134           let params =
 135             List.map (fun (key,value) -> (key, "'" ^ value ^ "'")) (params key)
 136           in
 137           logger#log
 138             `Debug
 139             (sprintf
 140               "Gdome_xslt.applyStylesheet params=%s"
 141               (String.concat ", " (List.map (fun (k,v) -> k^": "^v) params)));
 142           let res = Gdome_xslt.applyStylesheet ~source ~stylesheet ~params in
 143           res
 144         with e -> raise (Uwobo_failure (Printexc.to_string e)))
 145       input
 146       p_stylesheets
 147   in
 148     (* used to retrieve serialization options *)
 149   let last_stylesheet =
 150     try
 151       apply_properties logger last_stylesheet props
 152     with Unsupported_property prop ->
 153       raise (Uwobo_failure (sprintf "Unsupported property: %s" prop))
 154   in
 155   let p_last_stylesheet = Gdome_xslt.processStylesheet last_stylesheet in
 156   ((fun outchan ->                              (* serialization function *)
 157       Gdome_xslt.saveResultToChannel
 158         ~outchan
 159         ~result
 160         ~stylesheet:p_last_stylesheet),
 161    (get_property "media-type" last_stylesheet), (* media-type *)
 162    (get_property "encoding" last_stylesheet))   (* encoding *)
 163