+++ /dev/null
-(*
- * Copyright (C) 2003:
- * Stefano Zacchiroli <zack@cs.unibo.it>
- * for the HELM Team http://helm.cs.unibo.it/
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-open Printf;;
-open Uwobo_common;;
-
-exception Stylesheet_not_found of string ;;
-exception Stylesheet_already_in of string ;;
-exception Unsupported_property of string;;
-
-let xslNS = Gdome.domString "http://www.w3.org/1999/XSL/Transform"
-let outputS = Gdome.domString "output"
-let q_outputS = Gdome.domString "xsl:output"
-
-let default_properties = [] (* no default properties *)
-
- (** apply an output property to an xslt stylesheet *)
-let apply_property logger (element: Gdome.element) (name, value) =
- if Uwobo_common.is_supported_property name then begin
- logger#log `Debug (sprintf "Setting property: %s = %s" name value);
- element#setAttribute (Gdome.domString name) (Gdome.domString value)
- end else
- raise (Unsupported_property name)
-
- (** set a list of output properties in an xslt stylesheet, return a copy of
- the given stylesheet modified as needed, given stylesheet wont be changed by
- this operation.
- Before applying "props" properties applies a set of default properties as
- defined in "default_properties" *)
-let apply_properties logger last_stylesheet props =
- let last_stylesheet =
- new Gdome.document_of_node (last_stylesheet#cloneNode ~deep:true)
- in
- let output_element =
- let node_list = last_stylesheet#getElementsByTagNameNS xslNS outputS in
- (match node_list#item 0 with
- | None -> (* no xsl:output element, create it from scratch *)
- logger#log `Debug "Creating xsl:output node ...";
- let elt = last_stylesheet#createElementNS (Some xslNS) q_outputS in
- let root = last_stylesheet#get_documentElement in
- ignore (root#appendChild (elt :> Gdome.node));
- elt
- | Some node -> new Gdome.element_of_node node)
- in
- List.iter
- (apply_property logger (output_element :> Gdome.element))
- (default_properties @ props);
- last_stylesheet
-
-class styles =
- object (self)
- (* INVARIANT: 'stylesheets' and 'uris' are in sync *)
-
- (** association list: key * props -> I_gdome_xslt.processed_stylesheet
- It is the cache of the processed stylesheets *)
- val mutable p_stylesheets = []
- val mutable stylesheets = [] (** association list: key -> Gdome.document *)
- val mutable uris = [] (** association list: key -> uri *)
-
- val domImpl = Gdome.domImplementation ()
-
- (** process an XSLT stylesheet *)
- method private process uri =
- let dom = domImpl#createDocumentFromURI ~uri () in
- dom, Gdome_xslt.processStylesheet dom (* produce libXSLT messages in
- case of errors *)
-
- (* stylesheets management *)
-
- method add key uri =
- if (List.mem_assoc key uris) then
- raise (Stylesheet_already_in key)
- else begin
- uris <- (key, uri) :: uris;
- let stylesheet, p_stylesheet = self#process uri in
- stylesheets <- (key, stylesheet) :: stylesheets ;
- p_stylesheets <- ((key,[]), p_stylesheet) :: p_stylesheets ;
- end
-
- method remove key =
- if not (List.mem_assoc key uris) then
- raise (Stylesheet_not_found key)
- else begin
- uris <- List.remove_assoc key uris;
- stylesheets <- List.remove_assoc key stylesheets ;
- p_stylesheets <-
- List.filter (function ((key',_),_) -> key = key') p_stylesheets
- end
-
- method removeAll =
- uris <- [];
- stylesheets <- [];
- p_stylesheets <- []
-
- method reload key =
- (try
- let uri = List.assoc key uris in
- let stylesheet,p_stylesheet = self#process uri in
- stylesheets <-
- (key, stylesheet) :: (List.remove_assoc key stylesheets) ;
- (* we remove the processed stylesheet from the cache *)
- p_stylesheets <-
- List.filter (function ((key',_),_) -> key = key') p_stylesheets ;
- p_stylesheets <- ((key,[]),p_stylesheet)::p_stylesheets
- with Not_found ->
- raise (Stylesheet_not_found key))
-
- method reloadAll =
- let (stylesheets',p_stylesheets') =
- let processed =
- List.map (fun (key, uri) -> (key, self#process uri)) uris
- in
- List.map (function (key,(stylesheet,_)) -> key,stylesheet) processed,
- List.map
- (function (key,(_,p_stylesheet)) -> (key,[]),p_stylesheet) processed
- in
- stylesheets <- stylesheets' ;
- p_stylesheets <- p_stylesheets'
-
- (* stylesheets usage *)
-
- method keys = List.map fst uris
-
- method list =
- List.map
- (fun (key, uri) ->
- sprintf "key = %s, uri = %s" key (List.assoc key uris))
- uris
-
- method get keys props (logger : Uwobo_logger.sysLogger) =
- match List.rev keys with
- [] -> assert false
- | last_key::rev_keys ->
- let last_stylesheet =
- try
- List.assoc last_key stylesheets
- with Not_found -> raise (Stylesheet_not_found last_key)
- in
- let p_last_stylesheet =
- try
- List.assoc (last_key,props) p_stylesheets
- with
- Not_found ->
- (* Cache miss *)
- let last_stylesheet' =
- try
- apply_properties logger last_stylesheet props
- with Unsupported_property prop ->
- raise (Uwobo_failure (sprintf "Unsupported property: %s" prop))
- in
- let p_last_stylesheet =
- Gdome_xslt.processStylesheet last_stylesheet
- in
- p_stylesheets <-
- ((last_key,props),p_last_stylesheet)::p_stylesheets ;
- p_last_stylesheet
- in
- let p_stylesheets =
- List.fold_left
- (fun collected_styles key ->
- let p_stylesheet =
- try
- List.assoc (key,[]) p_stylesheets
- with
- Not_found ->
- (* Cache miss *)
-prerr_endline ("##### CACHE MISS: " ^ key) ;
- let stylesheet =
- try
- List.assoc key stylesheets
- with Not_found -> raise (Stylesheet_not_found key)
- in
- let p_stylesheet =
- Gdome_xslt.processStylesheet stylesheet
- in
- p_stylesheets <- ((key,[]),p_stylesheet)::p_stylesheets ;
- p_stylesheet
- in
- (key,p_stylesheet)::collected_styles)
- [last_key,p_last_stylesheet]
- rev_keys
- in
- p_stylesheets, last_stylesheet
- end
projects / helm.git / blobdiff