X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fuwobo%2Fuwobo_styles.ml;h=7730857ac3c998430ff2c3eb2c74c1be4a127437;hb=4167cea65ca58897d1a3dbb81ff95de5074700cc;hp=d866ede5d42136764ae69880b761b3f99fa4cae3;hpb=40d69bb0d68b6da47c625cca9c276fa19d6cc3aa;p=helm.git diff --git a/helm/uwobo/uwobo_styles.ml b/helm/uwobo/uwobo_styles.ml index d866ede5d..7730857ac 100644 --- a/helm/uwobo/uwobo_styles.ml +++ b/helm/uwobo/uwobo_styles.ml @@ -27,44 +27,68 @@ *) open Printf;; +open Uwobo_common;; exception Stylesheet_not_found of string ;; exception Stylesheet_already_in of string ;; - -type xslt_msg = - | LibXsltErrorMsg of string - | LibXsltDebugMsg of string -;; -type log = xslt_msg list ;; +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 *) - initializer - Gdome_xslt.setErrorCallback - (Some (fun msg -> self#appendMsg (LibXsltErrorMsg msg))); - Gdome_xslt.setDebugCallback - (Some (fun msg -> self#appendMsg (LibXsltDebugMsg msg))) - - + (** 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 mutable libXsltMsgs = [] (** libxslt's error and debugging messages *) val domImpl = Gdome.domImplementation () (** process an XSLT stylesheet *) method private process uri = let dom = domImpl#createDocumentFromURI ~uri () in - ignore (Gdome_xslt.processStylesheet dom); (* fills libXsltMsgs in case - of errors *) - dom - - (* libxslt's error and debugging messages handling *) - - method private appendMsg msg = libXsltMsgs <- msg :: libXsltMsgs - method private clearMsgs = libXsltMsgs <- [] + dom, Gdome_xslt.processStylesheet dom (* produce libXSLT messages in + case of errors *) (* stylesheets management *) @@ -72,68 +96,113 @@ class styles = if (List.mem_assoc key uris) then raise (Stylesheet_already_in key) else begin - self#clearMsgs; uris <- (key, uri) :: uris; - stylesheets <- (key, self#process uri) :: stylesheets; - libXsltMsgs + let stylesheet, p_stylesheet = self#process uri in + stylesheets <- (key, stylesheet) :: stylesheets ; + p_stylesheets <- ((key,[]), p_stylesheet) :: p_stylesheets ; end - method remove key : log = + 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; - [] (* no XSLT action -> no logs *) + stylesheets <- List.remove_assoc key stylesheets ; + p_stylesheets <- + List.filter (function ((key',_),_) -> key = key') p_stylesheets end - method removeAll : log = + method removeAll = uris <- []; stylesheets <- []; - [] (* no XSLT action -> no logs *) + p_stylesheets <- [] method reload key = (try - self#clearMsgs; let uri = List.assoc key uris in + let stylesheet,p_stylesheet = self#process uri in stylesheets <- - (key, self#process uri) :: (List.remove_assoc key stylesheets); - libXsltMsgs + (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 = - self#clearMsgs; - stylesheets <- List.map (fun (key, uri) -> (key, self#process uri)) uris; - libXsltMsgs + 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 = - let rev_keys = List.rev keys in - let last_key = List.hd rev_keys in - let p_stylesheets = - List.fold_left - (fun collected_styles key -> - let (key, stylesheet) = - try - List.find (fun (k, _) -> k = key) stylesheets - with Not_found -> raise (Stylesheet_not_found key) - in - (key, Gdome_xslt.processStylesheet stylesheet)::collected_styles) - [] - rev_keys - in - let last_stylesheet = - snd (List.find (fun (k, _) -> k = last_key) stylesheets) - in - (p_stylesheets, last_stylesheet) - + 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 *) + 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 -