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
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
+ 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 *)
logger#log `Debug (sprintf "Applying stylesheet %s ..." key);
try
let params =
- List.map (fun (key,value) -> (key, "'" ^ value ^ "'")) (params key)
+ List.map
+ (fun (key,value) ->
+ let quoted_value =
+ if String.contains value '\'' then
+ if String.contains value '"' then
+ raise
+ (Failure
+ ("A parameter value can not contain both single and " ^
+ "double quotes, since it must be a valid XPath string " ^
+ "literal"))
+ else
+ "\"" ^ value ^ "\""
+ else
+ "'" ^ value ^ "'"
+ in
+ (key,quoted_value)
+ ) (params key)
in
logger#log `Debug
(sprintf "Gdome_xslt.applyStylesheet params=%s"
input
p_stylesheets
in
- 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
+ (* 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 p_last_stylesheet = snd (List.hd (List.rev p_stylesheets)) in
((fun outchan -> (* serialization function *)
Gdome_xslt.saveResultToChannel ~outchan ~result
~stylesheet:p_last_stylesheet),
projects / helm.git / blobdiff