helm/uwobo/uwobo_styles.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 exception Stylesheet_not_found of string ;;
  33 exception Stylesheet_already_in of string ;;
  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 = [] (* no default properties *)
  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 else
  48     raise (Unsupported_property name)
  49
  50   (** set a list of output properties in an xslt stylesheet, return a copy of
  51   the given stylesheet modified as needed, given stylesheet wont be changed by
  52   this operation.
  53   Before applying "props" properties applies a set of default properties as
  54   defined in "default_properties" *)
  55 let apply_properties logger last_stylesheet props =
  56   let last_stylesheet =
  57     new Gdome.document_of_node (last_stylesheet#cloneNode ~deep:true)
  58   in
  59   let output_element =
  60     let node_list = last_stylesheet#getElementsByTagNameNS xslNS outputS in
  61     (match node_list#item 0 with
  62     | None -> (* no xsl:output element, create it from scratch *)
  63         logger#log `Debug "Creating xsl:output node ...";
  64         let elt = last_stylesheet#createElementNS (Some xslNS) q_outputS in
  65         let root = last_stylesheet#get_documentElement in
  66         ignore (root#appendChild (elt :> Gdome.node));
  67         elt
  68     | Some node -> new Gdome.element_of_node node)
  69   in
  70   List.iter
  71     (apply_property logger (output_element :> Gdome.element))
  72     (default_properties @ props);
  73   last_stylesheet
  74
  75 class styles =
  76   object (self)
  77     (* INVARIANT: 'stylesheets' and 'uris' are in sync *)
  78
  79      (** association list: key * props -> I_gdome_xslt.processed_stylesheet
  80          It is the cache of the processed stylesheets *)
  81     val mutable p_stylesheets = []
  82     val mutable stylesheets = []  (** association list: key -> Gdome.document *)
  83     val mutable uris = []         (** association list: key -> uri *)
  84
  85     val domImpl = Gdome.domImplementation ()
  86
  87       (** process an XSLT stylesheet *)
  88     method private process uri =
  89       let dom = domImpl#createDocumentFromURI ~uri () in
  90       dom, Gdome_xslt.processStylesheet dom  (* produce libXSLT messages in
  91                                                 case of errors *)
  92
  93     (* stylesheets management *)
  94
  95     method add key uri =
  96       if (List.mem_assoc key uris) then
  97         raise (Stylesheet_already_in key)
  98       else begin
  99         uris <- (key, uri) :: uris;
 100         let stylesheet, p_stylesheet = self#process uri in
 101          stylesheets <- (key, stylesheet) :: stylesheets ;
 102          p_stylesheets <- ((key,[]), p_stylesheet) :: p_stylesheets ;
 103       end
 104
 105     method remove key =
 106       if not (List.mem_assoc key uris) then
 107         raise (Stylesheet_not_found key)
 108       else begin
 109         uris <- List.remove_assoc key uris;
 110         stylesheets <- List.remove_assoc key stylesheets ;
 111         p_stylesheets <-
 112          List.filter (function ((key',_),_) -> key = key') p_stylesheets
 113       end
 114
 115     method removeAll =
 116       uris <- [];
 117       stylesheets <- [];
 118       p_stylesheets <- []
 119
 120     method reload key =
 121       (try
 122         let uri = List.assoc key uris in
 123         let stylesheet,p_stylesheet = self#process uri in
 124         stylesheets <-
 125           (key, stylesheet) :: (List.remove_assoc key stylesheets) ;
 126         (* we remove the processed stylesheet from the cache *)
 127         p_stylesheets <-
 128           List.filter (function ((key',_),_) -> key = key') p_stylesheets ;
 129         p_stylesheets <- ((key,[]),p_stylesheet)::p_stylesheets
 130       with Not_found ->
 131         raise (Stylesheet_not_found key))
 132
 133     method reloadAll =
 134       let (stylesheets',p_stylesheets') =
 135        let processed =
 136         List.map (fun (key, uri) -> (key, self#process uri)) uris
 137        in
 138         List.map (function (key,(stylesheet,_)) -> key,stylesheet) processed,
 139         List.map
 140          (function (key,(_,p_stylesheet)) -> (key,[]),p_stylesheet) processed
 141       in
 142        stylesheets <- stylesheets' ;
 143        p_stylesheets <- p_stylesheets'
 144
 145     (* stylesheets usage *)
 146
 147     method keys = List.map fst uris
 148
 149     method list =
 150       List.map
 151         (fun (key, uri) ->
 152           sprintf "key = %s, uri = %s" key (List.assoc key uris))
 153         uris
 154
 155     method get keys props (logger : Uwobo_logger.sysLogger) =
 156       match List.rev keys with
 157          [] -> assert false
 158        | last_key::rev_keys ->
 159           let last_stylesheet =
 160            try
 161             List.assoc last_key stylesheets
 162            with Not_found -> raise (Stylesheet_not_found last_key)
 163           in
 164           let p_last_stylesheet =
 165            try
 166             List.assoc (last_key,props) p_stylesheets
 167            with
 168             Not_found ->
 169              (* Cache miss *)
 170              let last_stylesheet' =
 171                try
 172                  apply_properties logger last_stylesheet props
 173                with Unsupported_property prop ->
 174                  raise (Uwobo_failure (sprintf "Unsupported property: %s" prop))
 175              in
 176              let p_last_stylesheet =
 177               Gdome_xslt.processStylesheet last_stylesheet
 178              in
 179               p_stylesheets <-
 180                ((last_key,props),p_last_stylesheet)::p_stylesheets ;
 181               p_last_stylesheet
 182           in
 183            let p_stylesheets =
 184             List.fold_left
 185               (fun collected_styles key ->
 186                 let p_stylesheet =
 187                  try
 188                   List.assoc (key,[]) p_stylesheets
 189                  with
 190                   Not_found ->
 191                    (* Cache miss *)
 192 prerr_endline ("##### CACHE MISS: " ^ key) ;
 193                    let stylesheet =
 194                      try
 195                        List.assoc key stylesheets
 196                      with Not_found -> raise (Stylesheet_not_found key)
 197                    in
 198                    let p_stylesheet =
 199                     Gdome_xslt.processStylesheet stylesheet
 200                    in
 201                     p_stylesheets <- ((key,[]),p_stylesheet)::p_stylesheets ;
 202                     p_stylesheet
 203                 in
 204                  (key,p_stylesheet)::collected_styles)
 205               [last_key,p_last_stylesheet]
 206               rev_keys
 207            in
 208             p_stylesheets, last_stylesheet
 209   end