- redesigned error and warning handling for libxslt

[helm.git] / helm / uwobo / uwobo_common.ml
diff --git a/helm/uwobo/uwobo_common.ml b/helm/uwobo/uwobo_common.ml

index c71024ce8c40427dae4804cf209c2af03fd58a0d..7ae0260ae274803ffbc24db745737b8910ad9cc5 100644 (file)
--- a/helm/uwobo/uwobo_common.ml
+++ b/helm/uwobo/uwobo_common.ml
@@ -26,9 +26,12 @@
   *  http://helm.cs.unibo.it/
   *)
  
-open Printf;;
+open Printf ;;
  
-exception Uwobo_failure of string;;
+exception Uwobo_failure of string ;;
+
+let uwobo_namespace = "http://helm.cs.unibo.it/uwobo" ;;
+let xsl_namespace = "http://helm.cs.unibo.it/uwobo" ;;
  
  let supported_properties = [
    "cdata-section-elements";
@@ -89,9 +92,15 @@ let usage_string =
        return a list of loaded stylesheets
      </p>
      <p>
-      <b><kbd>apply?xmluri=uri&keys=key1,key2,...[&param.name=value[&param.name=value[&...]]][&param.key.name=value[&param.key.name=value[&...]]][&prop.name[=value][&prop.name[=value][&...]]]</kbd></b><br />
+      <b><kbd>apply?xmluri=uri&keys=key1,key2,...[&errormode={ignore|comment|embed}][&debugmode={ignore|comment|embed}][&param.name=value[&param.name=value[&...]]][&param.key.name=value[&param.key.name=value[&...]]][&prop.name[=value][&prop.name[=value][&...]]]</kbd></b><br />
        apply a chain of stylesheets, specified by <em>key1, key2, ...</em>, to an
        input document, specified by <em>uri</em>.<br />
+      Error and debugging modes could be ste to three different values.
+      <em>ignore</em> means that LibXSLT messages are ignored; <em>comment</em>
+      meanst that LibXSLT messages are embedded in the result document inside an
+      XML like comment; <em>embed</em> means that LibXSLT messages are embedded
+      at the beginning of the result document (as childs of the root node) in
+      XML elements in the UWOBO namespace<br />
        Additional parameters can be set for each stylesheet application: global
        parameters (i.e. parameters passed to all stylesheets) are set using
        <em>param.name=value</em> syntax, per stylesheet parameters are set using
@@ -110,11 +119,66 @@ let usage_string =
  ;;
  
  let pp_error =
-  sprintf "<html><body><span style=\"color:red\">Error: %s</span></body></html>"
+  sprintf
+    "<html><body><span style=\"color:red\">Error: %s</span>%s</body></html>"
  ;;
-let return_error msg outchan =
-  Http_daemon.respond ~body:(pp_error msg) outchan;;
+let return_error msg ?(body = "") outchan =
+  Http_daemon.respond ~body:(pp_error msg body) outchan;;
  let bad_request body outchan =
    Http_daemon.respond_error ~code:400 ~body outchan
  ;;
  
+  (** {2 LibXSLT logging} *)
+
+type xslt_msg =
+  | LibXsltErrorMsg of string
+  | LibXsltDebugMsg of string
+;;
+
+let string_of_xslt_msg = function
+  | LibXsltErrorMsg msg -> "LibXSLT ERROR: " ^ msg
+  | LibXsltDebugMsg msg -> "LibXSLT DEBUG: " ^ msg
+;;
+
+type xslt_msg_mode =
+  | LibXsltMsgIgnore
+  | LibXsltMsgComment
+  | LibXsltMsgEmbed
+;;
+
+class libXsltLogger =
+  let is_libxslt_error = function LibXsltErrorMsg _ -> true | _ -> false in
+  let is_libxslt_debug = function LibXsltDebugMsg _ -> true | _ -> false in
+  let flatten_libxslt_msg = function
+    | LibXsltErrorMsg msg -> msg
+    | LibXsltDebugMsg msg -> msg
+  in
+  object (self)
+
+    initializer
+      Gdome_xslt.setErrorCallback
+        (Some (fun msg -> self#appendMsg (LibXsltErrorMsg msg)));
+      Gdome_xslt.setDebugCallback
+        (Some (fun msg -> self#appendMsg (LibXsltDebugMsg msg)))
+
+    val mutable libXsltMsgs = []  (** libxslt's error and debugging messages *)
+
+      (* libxslt's error and debugging messages handling *)
+
+    method private appendMsg msg = libXsltMsgs <- msg :: libXsltMsgs
+
+    method clearMsgs = libXsltMsgs <- []
+    method clearErrorMsgs =
+      libXsltMsgs <- List.filter is_libxslt_debug libXsltMsgs
+    method clearDebugMsgs =
+      libXsltMsgs <- List.filter is_libxslt_error libXsltMsgs
+
+    method msgs = libXsltMsgs
+    method errorMsgs =
+      List.map flatten_libxslt_msg (List.filter is_libxslt_error libXsltMsgs)
+    method debugMsgs =
+      List.map flatten_libxslt_msg (List.filter is_libxslt_debug libXsltMsgs)
+
+  end
+;;
+