Some (element#getAttribute domName)#to_string
else
None
+;;
+
+let namespaceURI = Some (Gdome.domString Uwobo_common.uwobo_namespace) ;;
+
+ (** output type wrt adding of debugging/error messages *)
+type outputType =
+ | XmlOutput of Gdome.node
+ | TextPlainOutput of Gdome.text
+ | NoOutput
+;;
+
+exception Found of int ;;
+
+ (** add debugging and/or error messages to a Gdome document. Handle three
+ distinct cases: (1) output contains an XML tree, (2) output contains only one
+ text node, (3) output contains no data.
+ If output contains an XML tree then users wishes are preserved and messages
+ are either not included or included as comments or included as XML ndoes.
+ If output contains only a text node comments are either not included or
+ included at the beginning of the textual output.
+ If output contains no data (i.e. DOM superroot node with no element or text
+ children) messages are embedded as XML comments or not embedded at all *)
+let add_msgs ~errormode ~debugmode ~msgs (doc: Gdome.document) =
+ let getOutputType (doc: Gdome.document) =
+ let children = doc#get_childNodes in
+ let len = children#get_length in
+ let rec find_element i =
+ if i > len then
+ raise Not_found
+ else
+ (match children#item i with
+ | Some node when node#get_nodeType = GdomeNodeTypeT.ELEMENT_NODE ->
+ XmlOutput node
+ | _ -> find_element (i + 1))
+ in
+ let rec find_text i =
+ if i > len then
+ raise Not_found
+ else
+ (match children#item i with
+ | Some node when node#get_nodeType = GdomeNodeTypeT.TEXT_NODE ->
+ TextPlainOutput (new Gdome.text_of_node node)
+ | _ -> find_element (i + 1))
+ in
+ if len = 0 then
+ NoOutput
+ else
+ (try find_element 0 with Not_found ->
+ (try find_text 0 with Not_found -> NoOutput))
+ in
+ match getOutputType (doc :> Gdome.document) with
+ | XmlOutput node ->
+ let add_generic_msg mode build tagname =
+ (match mode with
+ | LibXsltMsgIgnore -> (fun msg -> ())
+ | LibXsltMsgComment ->
+ (fun msg ->
+(* let contents = string_of_xslt_msg (build msg) ^ "<br />" in *)
+ let contents = string_of_xslt_msg (build msg) in
+ ignore (node#insertBefore
+ ~newChild:(doc#createComment
+ (Gdome.domString contents) :> Gdome.node)
+ ~refChild:node#get_firstChild))
+ | LibXsltMsgEmbed ->
+ (fun msg ->
+(* let contents = string_of_xslt_msg (build msg) ^ "<br />" in *)
+ let contents = string_of_xslt_msg (build msg) in
+ let element =
+ doc#createElementNS
+ ~namespaceURI ~qualifiedName:(Gdome.domString tagname)
+ in
+ ignore (element#appendChild
+ (doc#createTextNode
+ ~data:(Gdome.domString contents) :> Gdome.node));
+ ignore (node#insertBefore
+ ~newChild:(element :> Gdome.node)
+ ~refChild:node#get_firstChild)))
+ in
+ let add_error_msg =
+ add_generic_msg
+ errormode (fun msg -> LibXsltErrorMsg msg) "uwobo:error"
+ in
+ let add_debug_msg =
+ add_generic_msg
+ debugmode (fun msg -> LibXsltDebugMsg msg) "uwobo:debug"
+ in
+ List.iter
+ (function
+ | LibXsltErrorMsg msg -> add_error_msg msg
+ | LibXsltDebugMsg msg -> add_debug_msg msg)
+ (List.rev msgs) (* because each msg is added as 1st children *)
+| TextPlainOutput text ->
+ let add_generic_msg mode build =
+ (match mode with
+ | LibXsltMsgIgnore -> (fun _ -> ())
+ | LibXsltMsgComment | LibXsltMsgEmbed ->
+ (fun msg ->
+ text#insertData ~offset:0
+ ~arg:(Gdome.domString
+ (string_of_xslt_msg (build msg) ^ "\n"))))
+ in
+ let add_error_msg =
+ add_generic_msg errormode (fun msg -> LibXsltErrorMsg msg)
+ in
+ let add_debug_msg =
+ add_generic_msg debugmode (fun msg -> LibXsltDebugMsg msg)
+ in
+ List.iter
+ (function
+ | LibXsltErrorMsg msg -> add_error_msg msg
+ | LibXsltDebugMsg msg -> add_debug_msg msg)
+ (List.rev msgs) (* because each msg is added as 1st children *)
+| NoOutput ->
+ let add_generic_msg mode build =
+ (match mode with
+ | LibXsltMsgIgnore -> (fun _ -> ())
+ | LibXsltMsgComment | LibXsltMsgEmbed ->
+ (fun msg ->
+ let comment_node =
+ (* use comments anyway because text nodes aren't allowed in DOM as
+ superroot children *)
+ doc#createComment
+ (Gdome.domString (string_of_xslt_msg (build msg)))
+ in
+ ignore (doc#insertBefore ~newChild:(comment_node :> Gdome.node)
+ ~refChild:doc#get_firstChild)))
+ in
+ let add_error_msg =
+ add_generic_msg errormode (fun msg -> LibXsltErrorMsg msg)
+ in
+ let add_debug_msg =
+ add_generic_msg debugmode (fun msg -> LibXsltDebugMsg msg)
+ in
+ List.iter
+ (function
+ | LibXsltErrorMsg msg -> add_error_msg msg
+ | LibXsltDebugMsg msg -> add_debug_msg msg)
+ (List.rev msgs) (* because each msg is added as 1st children *)
+;;
let apply
~(logger: Uwobo_logger.sysLogger)
~(styles: Uwobo_styles.styles)
- ~keys ~params ~props ~input
+ ~keys ~params ~props
+ ~(veillogger: Uwobo_common.libXsltLogger)
+ ?(errormode = LibXsltMsgIgnore) ?(debugmode = LibXsltMsgIgnore)
+ input
=
(* "p_" prefix means "processed" *)
let (p_stylesheets, last_stylesheet) = styles#get keys in
input
p_stylesheets
in
+ (* add error and debugging messages to result document *)
+ add_msgs ~errormode ~debugmode ~msgs:veillogger#msgs result;
+(*
+ (* DEBUGGING *)
+ add_msgs
+ ~errormode:LibXsltMsgEmbed ~debugmode:LibXsltMsgEmbed
+ ~msgs:[LibXsltErrorMsg "error1"; LibXsltDebugMsg "debug1"]
+ result;
+*)
let last_stylesheet = (* used to retrieve serialization options *)
try
apply_properties logger last_stylesheet props
projects / helm.git / blobdiff