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 d7a1c4995025e6aa11ca4c3a1a2921374ed6f067..f8be17806310755f6c5b4f1ba4ea2f9be976f411 100644 (file)
--- a/helm/uwobo/uwobo_engine.ml
+++ b/helm/uwobo/uwobo_engine.ml
@@ -33,46 +33,8 @@ open Uwobo_common;;
   in /tmp/uwobo_intermediate_<seqno>_<pid>.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 3aa33877bfc479adaace3ef43fb357caded38262..6b4791e368e3e7c3462bff444dc512a3691ca62a 100644 (file)
--- 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 2817e14a5a48323f7f0decc58213c1dd4f10bb6a..95af2a484bd70cd845021b50d6dab4b6e509048b 100644 (file)
--- 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