X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fuwobo%2Fsrc%2Focaml%2Fuwobo_engine.ml;h=aad4f971b8d8032bc712a447e8ea145f801837b7;hb=a4df9661e15509e5da6ed9c57e3ab6a27a440c3f;hp=9e4850bbb6a3b35c5b617b50ebca37715c1f051f;hpb=beaf9a3cb95519e68e5806ac2f8a45b480d8e5ac;p=helm.git diff --git a/helm/uwobo/src/ocaml/uwobo_engine.ml b/helm/uwobo/src/ocaml/uwobo_engine.ml index 9e4850bbb..aad4f971b 100644 --- a/helm/uwobo/src/ocaml/uwobo_engine.ml +++ b/helm/uwobo/src/ocaml/uwobo_engine.ml @@ -1,72 +1,140 @@ - -(* Copyright (C) 2002, HELM Team. - * - * 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. +(* + * 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. * - * 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://cs.unibo.it/helm/. + * 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;; -let dump_args keys params props = - (sprintf " -

Uwobo_engine.apply: not yet implemented!

-Keys: %s
-Parameters:
-%s -Props: %s
-" - (String.concat ", " keys) - (String.concat - "
\n" - (List.map - (fun key -> - (sprintf - "Key: %s, Params: %s" - key - (String.concat - ", " - (List.map - (fun (key,value) -> sprintf "%s:%s" key value) - (params key))))) - keys)) - (String.concat - ", " - (List.map (fun (key,value) -> sprintf "%s:%s" key value) props))) + (** set this to true and uwobo will save transformation's intermediate results + 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 + 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 - (* TODO add global mutex, stylesheets are freezed at the request moment *) let apply - ~(logger: Uwobo_logger.processingLogger) + ~(logger: Uwobo_logger.sysLogger) ~(styles: Uwobo_styles.styles) - ~keys ~params ~props ~input = - let stylesheets = styles#get keys in - logger#log (dump_args keys params props); - logger#log "Creating input document ..."; - List.fold_left - (fun source (key, stylesheet) -> - logger#log (sprintf "Applying stylesheet %s ..." key); - try - Gdome_xslt.applyStylesheet ~source ~stylesheet ~params:(params key) - with e -> raise (Uwobo_failure (Printexc.to_string e))) - input - stylesheets + ~keys ~params ~props ~input + = + (* "p_" prefix means "processed" *) + let (p_stylesheets, last_stylesheet) = styles#get keys 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) -> (key, "'" ^ 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 + 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 + ((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 *)