X-Git-Url: http://matita.cs.unibo.it/gitweb/?p=helm.git;a=blobdiff_plain;f=helm%2Fuwobo%2Fuwobo_engine.ml;fp=helm%2Fuwobo%2Fuwobo_engine.ml;h=0000000000000000000000000000000000000000;hp=03a3b424d726f1c65faa2693529fc06b9415dd41;hb=3ef089a4c58fbe429dd539af6215991ecbe11ee2;hpb=1c7fb836e2af4f2f3d18afd0396701f2094265ff diff --git a/helm/uwobo/uwobo_engine.ml b/helm/uwobo/uwobo_engine.ml deleted file mode 100644 index 03a3b424d..000000000 --- a/helm/uwobo/uwobo_engine.ml +++ /dev/null @@ -1,263 +0,0 @@ -(* - * Copyright (C) 2003: - * Stefano Zacchiroli - * for the HELM Team http://helm.cs.unibo.it/ - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://helm.cs.unibo.it/ - *) - -open Printf;; -open Uwobo_common;; - - (** set this to true and uwobo will save transformation's intermediate results - in /tmp/uwobo_intermediate__.xml *) -let save_intermediate_results = false;; - -let xslNS = Gdome.domString "http://www.w3.org/1999/XSL/Transform" -let outputS = Gdome.domString "output" - - (** given a Gdome.document representing an XSLT stylesheet and an output - property return 'Some value' where 'value' is the property value, or None if - it's not defined *) -let get_property name (document: Gdome.document) = - let node_list = document#getElementsByTagNameNS xslNS outputS in - match node_list#item 0 with - | None -> None - | Some node -> - let element = new Gdome.element_of_node node in - let domName = Gdome.domString name in - if element#hasAttribute domName then - 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 - ~(veillogger: Uwobo_common.libXsltLogger) - ?(errormode = LibXsltMsgIgnore) ?(debugmode = LibXsltMsgIgnore) - input - = - (* "p_" prefix means "processed" *) - 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 *) - List.fold_left - (fun source (key, stylesheet) -> - logger#log `Debug (sprintf "Applying stylesheet %s ..." key); - try - let params = - 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" - (String.concat ", " (List.map (fun (k,v) -> k^": "^v) params))); - let res = Gdome_xslt.applyStylesheet ~source ~stylesheet ~params in - if save_intermediate_results then begin - let domImpl = Gdome.domImplementation () in - ignore - (domImpl#saveDocumentToFile - ~doc:res - ~name:(sprintf "/tmp/uwobo_intermediate_%d_%d.xml" - !intermediate_results_seqno (Unix.getpid())) - ()); - incr intermediate_results_seqno; - end; - res - with e -> raise (Uwobo_failure (Printexc.to_string e))) - 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 p_last_stylesheet = snd (List.hd (List.rev p_stylesheets)) in - ((fun outchan -> (* serialization function *) - Gdome_xslt.saveResultToChannel ~outchan ~result - ~stylesheet:p_last_stylesheet), - (get_property "media-type" last_stylesheet), (* media-type *) - (get_property "encoding" last_stylesheet)) (* encoding *) -