From: Claudio Sacerdoti Coen Date: Tue, 29 Apr 2003 16:14:25 +0000 (+0000) Subject: New: stylesheets are now partially cached (i.e. all the stylesheets which X-Git-Tag: submitted~51 X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=commitdiff_plain;h=1d4f3c9c4b5241c085b1af4fd7c2bf58585532a7;p=helm.git New: stylesheets are now partially cached (i.e. all the stylesheets which are applied using an empty list of props are now precompiled only when added or reloaded). See bug #75. --- diff --git a/helm/uwobo/uwobo_engine.ml b/helm/uwobo/uwobo_engine.ml index d7a1c4995..f8be17806 100644 --- a/helm/uwobo/uwobo_engine.ml +++ b/helm/uwobo/uwobo_engine.ml @@ -33,46 +33,8 @@ open Uwobo_common;; in /tmp/uwobo_intermediate__.xml *) let save_intermediate_results = false;; -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 (** given a Gdome.document representing an XSLT stylesheet and an output property return 'Some value' where 'value' is the property value, or None if @@ -237,7 +199,7 @@ let apply input = (* "p_" prefix means "processed" *) - let (p_stylesheets, last_stylesheet) = styles#get keys in + let (p_stylesheets,last_stylesheet) = styles#get keys props logger in logger#log `Debug "Creating input document ..."; let intermediate_results_seqno = ref 0 in let result = (* Gdome.document *) @@ -276,13 +238,7 @@ let apply ~msgs:[LibXsltErrorMsg "error1"; LibXsltDebugMsg "debug1"] result; *) - let last_stylesheet = (* used to retrieve serialization options *) - 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 + let p_last_stylesheet = snd (List.hd (List.rev p_stylesheets)) in ((fun outchan -> (* serialization function *) Gdome_xslt.saveResultToChannel ~outchan ~result ~stylesheet:p_last_stylesheet), diff --git a/helm/uwobo/uwobo_styles.ml b/helm/uwobo/uwobo_styles.ml index 3aa33877b..6b4791e36 100644 --- a/helm/uwobo/uwobo_styles.ml +++ b/helm/uwobo/uwobo_styles.ml @@ -31,11 +31,54 @@ 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 *) @@ -44,9 +87,8 @@ class styles = (** process an XSLT stylesheet *) method private process uri = let dom = domImpl#createDocumentFromURI ~uri () in - ignore (Gdome_xslt.processStylesheet dom); (* produce libXSLT messages in - case of errors *) - dom + dom, Gdome_xslt.processStylesheet dom (* produce libXSLT messages in + case of errors *) (* stylesheets management *) @@ -55,7 +97,9 @@ class styles = raise (Stylesheet_already_in key) else begin uris <- (key, uri) :: uris; - stylesheets <- (key, self#process uri) :: stylesheets + let stylesheet, p_stylesheet = self#process uri in + stylesheets <- (key, stylesheet) :: stylesheets ; + p_stylesheets <- ((key,[]), p_stylesheet) :: p_stylesheets ; end method remove key = @@ -63,23 +107,40 @@ class styles = raise (Stylesheet_not_found key) else begin uris <- List.remove_assoc key uris; - stylesheets <- List.remove_assoc key stylesheets + stylesheets <- List.remove_assoc key stylesheets ; + p_stylesheets <- + List.filter (function ((key',_),_) -> key = key') p_stylesheets end method removeAll = uris <- []; - stylesheets <- [] + stylesheets <- []; + p_stylesheets <- [] method reload key = (try 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) + (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 = - stylesheets <- List.map (fun (key, uri) -> (key, self#process uri)) uris + 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 *) @@ -91,25 +152,58 @@ class styles = 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 *) +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 - diff --git a/helm/uwobo/uwobo_styles.mli b/helm/uwobo/uwobo_styles.mli index 2817e14a5..95af2a484 100644 --- a/helm/uwobo/uwobo_styles.mli +++ b/helm/uwobo/uwobo_styles.mli @@ -66,13 +66,18 @@ class styles: at least stylesheet's key and URI *) method list: string list - (** @param key_list list of keys - @return a pair. First component of the returned pair is an association - list that maps given keys to gdome2-xslt processed stylesheets. Second - component of the returned pair is an unprocessed version of the - stylesheets corresponding to the latest key provided *) + (** + @param key_list non empty list of keys + @param props list of prop + @param logger the logger to be used to report errors and warnings + @return a pair. The first argument of the pair is an association list + that maps given keys to gdome2-xslt processed stylesheets. The last + stylesheet xsl:output element is modified according to the given + properties. The second argument of the pair is the last unprocessed + stylesheet. + *) method get: - string list -> + string list -> (string * string) list -> Uwobo_logger.sysLogger -> (string * I_gdome_xslt.processed_stylesheet) list * Gdome.document end