* 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";
let is_supported_property name = List.mem name supported_properties
-let version = "0.2.0" ;;
+let version = "0.2.1" ;;
let usage_string =
sprintf
<b><kbd>help</kbd></b><br />
display this help message
</p>
+ <p>
+ <b><kbd>newsession?port=p</kbd></b><br />
+ starts a new daemon on a given port <em>p</em>
+ </p>
+ <p>
+ <b><kbd>kill</kbd></b><br />
+ kills the daemon. The log file is mantained.
+ </p>
<p>
<b><kbd>add?bind=key,uri[&bind=key,uri[&...]]</kbd></b><br />
load a new stylesheet, specified by <em>uri</em>, and bind it to key
<em>key</em>
</p>
<p>
- <b><kbd>remove[?keys=key1,key2,...]</kbd></b><br />
+ <b><kbd>remove?keys=[key1,key2,...]</kbd></b><br />
unload stylesheets specified by <em>key1, key2, ...</em> or all
stylesheets if no key was given
</p>
<p>
- <b><kbd>reload[?keys=key1,key2,...]</kbd></b><br />
+ <b><kbd>reload?keys=[key1,key2,...]</kbd></b><br />
reload stylesheets specified by <em>key1, key2, ...</em> or all
stylesheets if no key was given
</p>
return a list of loaded stylesheets
</p>
<p>
- <b><kbd>apply?xmluri=uri&keys=key1,key2,...[¶m.name=value[¶m.name=value[&...]]][¶m.key.name=value[¶m.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}][¶m.name=value[¶m.name=value[&...]]][¶m.key.name=value[¶m.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
(String.concat ", " supported_properties) (* supported properties *)
;;
-let pp_error = sprintf "<html><body><h1>Error: %s</h1></body></html>";;
-let return_error msg outchan =
- Http_daemon.respond ~body:(pp_error msg) outchan;;
+let pp_error =
+ sprintf
+ "<html><body><span style=\"color:red\">Error: %s</span>%s</body></html>"
+;;
+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
+;;
projects / helm.git / blobdiff