*)
open Printf;;
+open Uwobo_common;;
exception Stylesheet_not_found of string ;;
exception Stylesheet_already_in of string ;;
-
-type xslt_msg =
- | LibXsltErrorMsg of string
- | LibXsltDebugMsg of string
-;;
-type log = xslt_msg list ;;
+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
class styles =
object (self)
(* INVARIANT: 'stylesheets' and 'uris' are in sync *)
- initializer
- Gdome_xslt.setErrorCallback
- (Some (fun msg -> self#appendMsg (LibXsltErrorMsg msg)));
- Gdome_xslt.setDebugCallback
- (Some (fun msg -> self#appendMsg (LibXsltDebugMsg msg)))
-
-
+ (** association list: key * props -> I_gdome_xslt.processed_stylesheet
+ It is the cache of the processed stylesheets *)
+ val mutable p_stylesheets = []
val mutable stylesheets = [] (** association list: key -> Gdome.document *)
val mutable uris = [] (** association list: key -> uri *)
- val mutable libXsltMsgs = [] (** libxslt's error and debugging messages *)
val domImpl = Gdome.domImplementation ()
(** process an XSLT stylesheet *)
method private process uri =
let dom = domImpl#createDocumentFromURI ~uri () in
- ignore (Gdome_xslt.processStylesheet dom); (* fills libXsltMsgs in case
- of errors *)
- dom
-
- (* libxslt's error and debugging messages handling *)
-
- method private appendMsg msg = libXsltMsgs <- msg :: libXsltMsgs
- method private clearMsgs = libXsltMsgs <- []
+ dom, Gdome_xslt.processStylesheet dom (* produce libXSLT messages in
+ case of errors *)
(* stylesheets management *)
if (List.mem_assoc key uris) then
raise (Stylesheet_already_in key)
else begin
- self#clearMsgs;
uris <- (key, uri) :: uris;
- stylesheets <- (key, self#process uri) :: stylesheets;
- libXsltMsgs
+ let stylesheet, p_stylesheet = self#process uri in
+ stylesheets <- (key, stylesheet) :: stylesheets ;
+ p_stylesheets <- ((key,[]), p_stylesheet) :: p_stylesheets ;
end
- method remove key : log =
+ method remove key =
if not (List.mem_assoc key uris) then
raise (Stylesheet_not_found key)
else begin
uris <- List.remove_assoc key uris;
- stylesheets <- List.remove_assoc key stylesheets;
- [] (* no XSLT action -> no logs *)
+ stylesheets <- List.remove_assoc key stylesheets ;
+ p_stylesheets <-
+ List.filter (function ((key',_),_) -> key = key') p_stylesheets
end
- method removeAll : log =
+ method removeAll =
uris <- [];
stylesheets <- [];
- [] (* no XSLT action -> no logs *)
+ p_stylesheets <- []
method reload key =
(try
- self#clearMsgs;
let uri = List.assoc key uris in
+ let stylesheet,p_stylesheet = self#process uri in
stylesheets <-
- (key, self#process uri) :: (List.remove_assoc key stylesheets);
- libXsltMsgs
+ (key, stylesheet) :: (List.remove_assoc key stylesheets) ;
+ (* we remove the processed stylesheet from the cache *)
+ p_stylesheets <-
+ List.filter (function ((key',_),_) -> key = key') p_stylesheets ;
+ p_stylesheets <- ((key,[]),p_stylesheet)::p_stylesheets
with Not_found ->
raise (Stylesheet_not_found key))
method reloadAll =
- self#clearMsgs;
- stylesheets <- List.map (fun (key, uri) -> (key, self#process uri)) uris;
- libXsltMsgs
+ let (stylesheets',p_stylesheets') =
+ let processed =
+ List.map (fun (key, uri) -> (key, self#process uri)) uris
+ in
+ List.map (function (key,(stylesheet,_)) -> key,stylesheet) processed,
+ List.map
+ (function (key,(_,p_stylesheet)) -> (key,[]),p_stylesheet) processed
+ in
+ stylesheets <- stylesheets' ;
+ p_stylesheets <- p_stylesheets'
(* stylesheets usage *)
sprintf "key = %s, uri = %s" key (List.assoc key uris))
uris
- method get keys =
- let rev_keys = List.rev keys in
- let last_key = List.hd rev_keys in
- let p_stylesheets =
- List.fold_left
- (fun collected_styles key ->
- let (key, stylesheet) =
- try
- List.find (fun (k, _) -> k = key) stylesheets
- with Not_found -> raise (Stylesheet_not_found key)
- in
- (key, Gdome_xslt.processStylesheet stylesheet)::collected_styles)
- []
- rev_keys
- in
- let last_stylesheet =
- snd (List.find (fun (k, _) -> k = last_key) stylesheets)
- in
- (p_stylesheets, last_stylesheet)
-
+ method get keys props (logger : Uwobo_logger.sysLogger) =
+ match List.rev keys with
+ [] -> assert false
+ | last_key::rev_keys ->
+ let last_stylesheet =
+ try
+ List.assoc last_key stylesheets
+ with Not_found -> raise (Stylesheet_not_found last_key)
+ in
+ let p_last_stylesheet =
+ try
+ List.assoc (last_key,props) p_stylesheets
+ with
+ Not_found ->
+ (* Cache miss *)
+ let last_stylesheet' =
+ 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
+ p_stylesheets <-
+ ((last_key,props),p_last_stylesheet)::p_stylesheets ;
+ p_last_stylesheet
+ in
+ let p_stylesheets =
+ List.fold_left
+ (fun collected_styles key ->
+ let p_stylesheet =
+ try
+ List.assoc (key,[]) p_stylesheets
+ with
+ Not_found ->
+ (* Cache miss *)
+ let stylesheet =
+ try
+ List.assoc key stylesheets
+ with Not_found -> raise (Stylesheet_not_found key)
+ in
+ let p_stylesheet =
+ Gdome_xslt.processStylesheet stylesheet
+ in
+ p_stylesheets <- ((key,[]),p_stylesheet)::p_stylesheets ;
+ p_stylesheet
+ in
+ (key,p_stylesheet)::collected_styles)
+ [last_key,p_last_stylesheet]
+ rev_keys
+ in
+ p_stylesheets, last_stylesheet
end
-
projects / helm.git / blobdiff