X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fuwobo%2Fuwobo_styles.ml;fp=helm%2Fuwobo%2Fuwobo_styles.ml;h=0000000000000000000000000000000000000000;hb=c7514aaa249a96c5fdd39b1123fbdb38d92f20b6;hp=6b4791e368e3e7c3462bff444dc512a3691ca62a;hpb=1c7fb836e2af4f2f3d18afd0396701f2094265ff;p=helm.git diff --git a/helm/uwobo/uwobo_styles.ml b/helm/uwobo/uwobo_styles.ml deleted file mode 100644 index 6b4791e36..000000000 --- a/helm/uwobo/uwobo_styles.ml +++ /dev/null @@ -1,209 +0,0 @@ -(* - * Copyright (C) 2003: - * Stefano Zacchiroli - * 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