- catch libxslt error and debugging messages and return them to the user

[helm.git] / helm / uwobo / uwobo_styles.ml

diff --git a/helm/uwobo/uwobo_styles.ml b/helm/uwobo/uwobo_styles.ml
index 9f954f63dda211dc3bae558aaf32dfebc746fbb2..d866ede5d42136764ae69880b761b3f99fa4cae3 100644 (file)
--- a/helm/uwobo/uwobo_styles.ml
+++ b/helm/uwobo/uwobo_styles.ml
@@ -28,74 +28,112 @@
 
 open Printf;;
 
-exception Stylesheet_not_found of string;;
-exception Stylesheet_already_in of string;;
+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 ;;
 
 class styles =
   object (self)
     (* INVARIANT: 'stylesheets' and 'uris' are in sync *)
 
-    val mutable stylesheets = []
-    val mutable uris = []
+    initializer
+      Gdome_xslt.setErrorCallback
+        (Some (fun msg -> self#appendMsg (LibXsltErrorMsg msg)));
+      Gdome_xslt.setDebugCallback
+        (Some (fun msg -> self#appendMsg (LibXsltDebugMsg msg)))
+
+      
+    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 = domImpl#createDocumentFromURI ~uri ()
+    method private process uri =
+      let dom = domImpl#createDocumentFromURI ~uri () in
+      ignore (Gdome_xslt.processStylesheet dom);  (* fills libXsltMsgs in case
+                                                  of errors *)
+      dom
 
-    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)
+      (* libxslt's error and debugging messages handling *)
+
+    method private appendMsg msg = libXsltMsgs <- msg :: libXsltMsgs
+    method private clearMsgs = libXsltMsgs <- []
+
+    (* stylesheets management *)
 
     method add key uri =
       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
+        stylesheets <- (key, self#process uri) :: stylesheets;
+        libXsltMsgs
       end
 
-    method remove key =
+    method remove key : log =
       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
+        stylesheets <- List.remove_assoc key stylesheets;
+        []  (* no XSLT action -> no logs *)
       end
 
-    method removeAll = uris <- []; stylesheets <- []
-
-    method list =
-      List.map
-        (fun (key, uri) ->
-          sprintf "key = %s, uri = %s" key (List.assoc key uris))
-        uris
+    method removeAll : log =
+      uris <- [];
+      stylesheets <- [];
+      []  (* no XSLT action -> no logs *)
 
     method reload key =
       (try
+        self#clearMsgs;
         let uri = List.assoc key uris in
         stylesheets <-
-          (key, self#process uri) :: (List.remove_assoc key stylesheets)
+          (key, self#process uri) :: (List.remove_assoc key stylesheets);
+        libXsltMsgs
       with Not_found ->
         raise (Stylesheet_not_found key))
 
     method reloadAll =
-      stylesheets <- List.map (fun (key, uri) -> (key, self#process uri)) uris
+      self#clearMsgs;
+      stylesheets <- List.map (fun (key, uri) -> (key, self#process uri)) uris;
+      libXsltMsgs
+
+    (* stylesheets usage *)
+
+    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)
 
   end