helm/uwobo/src/ocaml/uwobo_styles.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
  29 exception Stylesheet_not_found of string;;
  30 exception Stylesheet_already_in of string;;
  31
  32 class styles =
  33   object (self)
  34     (* INVARIANT: 'stylesheets' and 'uris' are in sync *)
  35
  36     inherit Uwobo_common.threadSafe
  37
  38     val mutable stylesheets = []
  39     val mutable uris = []
  40     val domImpl = Gdome.domImplementation ()
  41
  42       (** process an XSLT stylesheet *)
  43     method private process uri = domImpl#createDocumentFromURI ~uri ()
  44
  45     method get keys =
  46       self#doReader (lazy (
  47         let rev_keys = List.rev keys in
  48         let last_key = List.hd rev_keys in
  49         let p_stylesheets =
  50           List.fold_left
  51             (fun collected_styles key ->
  52               let (key, stylesheet) =
  53                 try
  54                   List.find (fun (k, _) -> k = key) stylesheets
  55                 with Not_found -> raise (Stylesheet_not_found key)
  56               in
  57               (key, Gdome_xslt.processStylesheet stylesheet)::collected_styles)
  58             []
  59             rev_keys
  60         in
  61         let last_stylesheet =
  62           snd (List.find (fun (k, _) -> k = last_key) stylesheets)
  63         in
  64         (p_stylesheets, last_stylesheet)
  65       ))
  66
  67     method add key uri =
  68       self#doWriter (lazy (
  69         if (List.mem_assoc key uris) then
  70           raise (Stylesheet_already_in key)
  71         else begin
  72           uris <- (key, uri) :: uris;
  73           stylesheets <- (key, self#process uri) :: stylesheets
  74         end
  75       ))
  76
  77     method remove key =
  78       self#doWriter (lazy (
  79         if not (List.mem_assoc key uris) then
  80           raise (Stylesheet_not_found key)
  81         else begin
  82           uris <- List.remove_assoc key uris;
  83           stylesheets <- List.remove_assoc key stylesheets
  84         end
  85       ))
  86
  87     method removeAll =
  88       self#doWriter (lazy (
  89         uris <- [];
  90         stylesheets <- []
  91       ))
  92
  93     method list =
  94       let uris = self#doReader (lazy (
  95         uris
  96       ))
  97       in
  98       List.map
  99         (fun (key, uri) -> sprintf "key = %s, uri = %s" key (List.assoc key uris))
 100         uris
 101
 102     method reload key =
 103       self#doWriter (lazy (
 104         (try
 105           let uri = List.assoc key uris in
 106           stylesheets <-
 107             (key, self#process uri) :: (List.remove_assoc key stylesheets)
 108         with Not_found ->
 109           raise (Stylesheet_not_found key))
 110       ))
 111
 112     method reloadAll =
 113       self#doWriter (lazy (
 114         stylesheets <- List.map (fun (key, uri) -> (key, self#process uri)) uris
 115       ))
 116
 117   end
 118