X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fuwobo%2Fuwobo_engine.ml;h=03a3b424d726f1c65faa2693529fc06b9415dd41;hb=4167cea65ca58897d1a3dbb81ff95de5074700cc;hp=aad4f971b8d8032bc712a447e8ea145f801837b7;hpb=47b0c2c1b421b62302b1957954912b4c0dfba9fa;p=helm.git diff --git a/helm/uwobo/uwobo_engine.ml b/helm/uwobo/uwobo_engine.ml index aad4f971b..03a3b424d 100644 --- a/helm/uwobo/uwobo_engine.ml +++ b/helm/uwobo/uwobo_engine.ml @@ -33,46 +33,8 @@ open Uwobo_common;; in /tmp/uwobo_intermediate__.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 @@ -88,14 +50,156 @@ let get_property name (document: Gdome.document) = 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) ^ "
" 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) ^ "
" 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 *) @@ -104,7 +208,23 @@ let apply 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" @@ -125,13 +245,16 @@ let apply 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),