From: Stefano Zacchiroli Date: Mon, 16 May 2005 16:03:13 +0000 (+0000) Subject: - no longer needs PXP X-Git-Tag: single_binding~54 X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=commitdiff_plain;h=dfdf5642131761008f0b0430594a83d45ab62789;p=helm.git - no longer needs PXP - added "interpolate" paramater to register iterators --- diff --git a/helm/ocaml/METAS/meta.helm-registry.src b/helm/ocaml/METAS/meta.helm-registry.src index 505ff1846..82d364016 100644 --- a/helm/ocaml/METAS/meta.helm-registry.src +++ b/helm/ocaml/METAS/meta.helm-registry.src @@ -1,4 +1,4 @@ -requires="str netstring helm-pxp" +requires="str netstring helm-xml" version="0.0.1" archive(byte)="registry.cma" archive(native)="registry.cmxa" diff --git a/helm/ocaml/registry/.cvsignore b/helm/ocaml/registry/.cvsignore index 702419146..f72bbdfab 100644 --- a/helm/ocaml/registry/.cvsignore +++ b/helm/ocaml/registry/.cvsignore @@ -5,3 +5,4 @@ *.cmxa *.o *.cmx +test diff --git a/helm/ocaml/registry/.ocamlinit b/helm/ocaml/registry/.ocamlinit index 352cad8ba..efcbda003 100644 --- a/helm/ocaml/registry/.ocamlinit +++ b/helm/ocaml/registry/.ocamlinit @@ -2,7 +2,6 @@ #thread;; #require "str";; #require "netstring";; -#require "pxp";; -#require "helm-pxp";; +#require "helm-xml";; #load "registry.cma";; open Helm_registry;; diff --git a/helm/ocaml/registry/Makefile b/helm/ocaml/registry/Makefile index e6a861689..e92099f6e 100644 --- a/helm/ocaml/registry/Makefile +++ b/helm/ocaml/registry/Makefile @@ -1,6 +1,6 @@ PACKAGE = registry -REQUIRES = str netstring helm-pxp unix +REQUIRES = str netstring unix helm-xml INTERFACE_FILES = helm_registry.mli IMPLEMENTATION_FILES = helm_registry.ml diff --git a/helm/ocaml/registry/helm_registry.ml b/helm/ocaml/registry/helm_registry.ml index 521362090..8966bb947 100644 --- a/helm/ocaml/registry/helm_registry.ml +++ b/helm/ocaml/registry/helm_registry.ml @@ -97,6 +97,10 @@ let interpolated_key_rex = Str.regexp ("\\$(" ^ valid_key_rex_raw ^ ")") let dot_rex = Str.regexp "\\." let spaces_rex = Str.regexp "[ \t\n\r]+" let heading_spaces_rex = Str.regexp "^[ \t\n\r]+" +let margin_blanks_rex = + Str.regexp "^\\([ \t\n\r]*\\)\\([^ \t\n\r]*\\)\\([ \t\n\r]*\\)$" + +let strip_blanks s = Str.global_replace margin_blanks_rex "\\2" s let split s = (* trailing blanks are removed per default by split *) @@ -166,7 +170,7 @@ let get registry key = aux stack key) value in - aux [] key + strip_blanks (aux [] key) let set registry = set' registry @@ -213,127 +217,235 @@ let add_validator ~key ~validator ~descr = id *) -open Pxp_dtd -open Pxp_document -open Pxp_types -open Pxp_yacc - -let save_to = - let dtd = new dtd PxpHelmConf.pxp_config.warner `Enc_utf8 in - let dot_RE = Str.regexp "\\." in - let create_key_node key value = (* create a value *) - let element = - create_element_node ~valcheck:false PxpHelmConf.pxp_spec dtd - "key" ["name", key] - in - let data = create_data_node PxpHelmConf.pxp_spec dtd value in - element#append_node data; - element +type xml_tree = + | Cdata of string + | Element of string * (string * string) list * xml_tree list + +let dot_RE = Str.regexp "\\." + +let xml_tree_of_registry registry = + let has_child name elements = + List.exists + (function + | Element (_, ["name", name'], _) when name = name' -> true + | _ -> false) + elements in - let is_section name = - fun node -> - match node#node_type with - | T_element "section" -> - (try node#attribute "name" = Value name with Not_found -> false) - | _ -> false + let rec get_child name = function + | [] -> assert false + | (Element (_, ["name", name'], _) as child) :: tl when name = name' -> + child, tl + | hd :: tl -> + let child, rest = get_child name tl in + child, hd :: rest in - let add_key_node root sections key value = - let rec aux node = function - | [] -> - let key_node = create_key_node key value in - node#append_node key_node - | section :: tl -> - let next_node = - try - find ~deeply:false (is_section section) node - with Not_found -> - let section_node = - create_element_node ~valcheck:false PxpHelmConf.pxp_spec dtd - "section" ["name", section] - in - node#append_node section_node; - section_node - in - aux next_node tl - in - aux root sections + let rec add_key path value tree = + match path, tree with + | [key], Element (name, attrs, children) -> + Element (name, attrs, + Element ("key", ["name", key], + [Cdata (strip_blanks value)]) :: children) + | dir :: path, Element (name, attrs, children) -> + if has_child dir children then + let child, rest = get_child dir children in + Element (name, attrs, add_key path value child :: rest) + else + Element (name, attrs, + ((add_key path value (Element ("section", ["name", dir], []))) + :: children)) + | _ -> assert false in - fun registry fname -> - let xml_root = - create_element_node ~valcheck:false PxpHelmConf.pxp_spec dtd - "helm_registry" [] - in - Hashtbl.iter - (fun key value -> - let sections, key = - let hd, tl = - match List.rev (Str.split dot_RE key) with - | hd :: tl -> hd, tl - | _ -> assert false - in - List.rev tl, hd - in - add_key_node xml_root sections key value) - registry; - let outfile = open_out fname in - Unix.lockf (Unix.descr_of_out_channel outfile) Unix.F_LOCK 0; (* blocks *) - if - Unix.system "xmllint --version &> /dev/null" = Unix.WEXITED 0 - then begin - let (xmllint_in, xmllint_out) = - Unix.open_process "xmllint --format --encode utf8 -" - in - xml_root#write (`Out_channel xmllint_out) `Enc_utf8; - close_out xmllint_out; - try - while true do - output_string outfile (input_line xmllint_in ^ "\n") - done - with End_of_file -> - close_in xmllint_in; - ignore (Unix.close_process (xmllint_in, xmllint_out)) - end else - xml_root#write (`Out_channel outfile) `Enc_utf8; - Unix.lockf (Unix.descr_of_out_channel outfile) Unix.F_ULOCK 0; - close_out outfile - -let load_from_absolute = - let config = PxpHelmConf.pxp_config in - let entry = `Entry_document [ `Extend_dtd_fully; `Parse_xml_decl ] in - let fold_key key_stack key = - match key_stack with - | [] -> key - | _ -> String.concat "." key_stack ^ "." ^ key + Hashtbl.fold + (fun k v tree -> add_key ("helm_registry" :: (Str.split dot_RE k)) v tree) + registry + (Element ("helm_registry", [], [])) + +let rec stream_of_xml_tree = function + | Cdata s -> Xml.xml_cdata s + | Element (name, attrs, children) -> + Xml.xml_nempty name + (List.map (fun (n, v) -> (None, n, v)) attrs) + (stream_of_xml_trees children) +and stream_of_xml_trees = function + | [] -> [< >] + | hd :: tl -> [< stream_of_xml_tree hd; stream_of_xml_trees tl >] + +let save_to registry fname = + let token_stream = stream_of_xml_tree (xml_tree_of_registry registry) in + let oc = open_out fname in + Xml.pp_to_outchan token_stream oc; + close_out oc + +(* PXP version *) +(*open Pxp_dtd*) +(*open Pxp_document*) +(*open Pxp_types*) +(*open Pxp_yacc*) + +(*let save_to =*) +(* let dtd = new dtd PxpHelmConf.pxp_config.warner `Enc_utf8 in*) +(* let create_key_node key value = |+ create a value +|*) +(* let element =*) +(* create_element_node ~valcheck:false PxpHelmConf.pxp_spec dtd*) +(* "key" ["name", key]*) +(* in*) +(* let data = create_data_node PxpHelmConf.pxp_spec dtd value in*) +(* element#append_node data;*) +(* element*) +(* in*) +(* let is_section name =*) +(* fun node ->*) +(* match node#node_type with*) +(* | T_element "section" ->*) +(* (try node#attribute "name" = Value name with Not_found -> false)*) +(* | _ -> false*) +(* in*) +(* let add_key_node root sections key value =*) +(* let rec aux node = function*) +(* | [] ->*) +(* let key_node = create_key_node key value in*) +(* node#append_node key_node*) +(* | section :: tl ->*) +(* let next_node =*) +(* try*) +(* find ~deeply:false (is_section section) node*) +(* with Not_found ->*) +(* let section_node =*) +(* create_element_node ~valcheck:false PxpHelmConf.pxp_spec dtd*) +(* "section" ["name", section]*) +(* in*) +(* node#append_node section_node;*) +(* section_node*) +(* in*) +(* aux next_node tl*) +(* in*) +(* aux root sections*) +(* in*) +(* fun registry fname ->*) +(* let xml_root =*) +(* create_element_node ~valcheck:false PxpHelmConf.pxp_spec dtd*) +(* "helm_registry" []*) +(* in*) +(* Hashtbl.iter*) +(* (fun key value ->*) +(* let sections, key =*) +(* let hd, tl =*) +(* match List.rev (Str.split dot_RE key) with*) +(* | hd :: tl -> hd, tl*) +(* | _ -> assert false*) +(* in*) +(* List.rev tl, hd*) +(* in*) +(* add_key_node xml_root sections key value)*) +(* registry;*) +(* let outfile = open_out fname in*) +(* Unix.lockf (Unix.descr_of_out_channel outfile) Unix.F_LOCK 0; |+ blocks +|*) +(* if*) +(* Unix.system "xmllint --version &> /dev/null" = Unix.WEXITED 0*) +(* then begin*) +(* let (xmllint_in, xmllint_out) =*) +(* Unix.open_process "xmllint --format --encode utf8 -"*) +(* in*) +(* xml_root#write (`Out_channel xmllint_out) `Enc_utf8;*) +(* close_out xmllint_out;*) +(* try*) +(* while true do*) +(* output_string outfile (input_line xmllint_in ^ "\n")*) +(* done*) +(* with End_of_file ->*) +(* close_in xmllint_in;*) +(* ignore (Unix.close_process (xmllint_in, xmllint_out))*) +(* end else*) +(* xml_root#write (`Out_channel outfile) `Enc_utf8;*) +(* Unix.lockf (Unix.descr_of_out_channel outfile) Unix.F_ULOCK 0;*) +(* close_out outfile*) + +(* PXP version *) +(*let load_from_absolute =*) +(* let config = PxpHelmConf.pxp_config in*) +(* let entry = `Entry_document [ `Extend_dtd_fully; `Parse_xml_decl ] in*) +(* let fold_key key_stack key =*) +(* match key_stack with*) +(* | [] -> key*) +(* | _ -> String.concat "." key_stack ^ "." ^ key*) +(* in*) +(* fun registry fname ->*) +(* debug_print ("Loading configuration from " ^ fname);*) +(* let document =*) +(* parse_wfdocument_entity config (from_file fname) PxpHelmConf.pxp_spec*) +(* in*) +(* let rec aux key_stack node =*) +(* node#iter_nodes (fun n ->*) +(* try*) +(* (match n#node_type with*) +(* | T_element "section" ->*) +(* let section = n#required_string_attribute "name" in*) +(* aux (key_stack @ [section]) n*) +(* | T_element "key" ->*) +(* let key = n#required_string_attribute "name" in*) +(* let value = n#data in*) +(* set registry ~key:(fold_key key_stack key) ~value*) +(* | _ -> ())*) +(* with exn ->*) +(* let (fname, line, pos) = n#position in*) +(* raise (Parse_error (fname, line, pos,*) +(* "Uncaught exception: " ^ Printexc.to_string exn)))*) +(* in*) +(* let backup = backup_registry registry in*) +(* Hashtbl.clear registry;*) +(* try*) +(* aux [] document#root*) +(* with exn ->*) +(* restore_registry backup registry;*) +(* raise exn*) + +(* XmlPushParser version *) +let load_from_absolute registry fname = + let path = ref [] in (*
elements entered so far *) + let in_key = ref false in (* have we entered a element? *) + let push_path name = path := name :: !path in + let pop_path () = path := List.tl !path in + let start_element tag attrs = + match tag, attrs with + | "section", ["name", name] -> push_path name + | "key", ["name", name] -> in_key := true; push_path name + | "helm_registry", _ -> () + | tag, _ -> + raise (Parse_error (fname, ~-1, ~-1, + (sprintf "unexpected element <%s> or wrong attribute set" tag))) in - fun registry fname -> - debug_print ("Loading configuration from " ^ fname); - let document = - parse_wfdocument_entity config (from_file fname) PxpHelmConf.pxp_spec - in - let rec aux key_stack node = - node#iter_nodes (fun n -> - try - (match n#node_type with - | T_element "section" -> - let section = n#required_string_attribute "name" in - aux (key_stack @ [section]) n - | T_element "key" -> - let key = n#required_string_attribute "name" in - let value = n#data in - set registry ~key:(fold_key key_stack key) ~value - | _ -> ()) - with exn -> - let (fname, line, pos) = n#position in - raise (Parse_error (fname, line, pos, - "Uncaught exception: " ^ Printexc.to_string exn))) - in - let backup = backup_registry registry in - Hashtbl.clear registry; - try - aux [] document#root - with exn -> - restore_registry backup registry; - raise exn + let end_element tag = + match tag with + | "section" -> pop_path () + | "key" -> in_key := false; pop_path () + | "helm_registry" -> () + | _ -> assert false + in + let character_data text = + if !in_key then + let key = String.concat "." (List.rev !path) in + let value = + if Hashtbl.mem registry key then + Hashtbl.find registry key ^ text + else + text + in + set registry ~key ~value + in + let callbacks = { + XmlPushParser.default_callbacks with + XmlPushParser.start_element = Some start_element; + XmlPushParser.end_element = Some end_element; + XmlPushParser.character_data = Some character_data; + } in + let xml_parser = XmlPushParser.create_parser callbacks in + let backup = backup_registry registry in + Hashtbl.clear registry; + try + XmlPushParser.parse xml_parser (`File fname) + with exn -> + restore_registry backup registry; + raise exn let load_from registry ?path fname = if Filename.is_relative fname then begin @@ -358,21 +470,24 @@ let load_from registry ?path fname = end else load_from_absolute registry fname -let fold registry ?prefix f init = +let fold registry ?prefix ?(interpolate = true) f init = + let value_of k v = if interpolate then get registry k else strip_blanks v in match prefix with - | None -> Hashtbl.fold (fun k v acc -> f acc k v) registry init + | None -> Hashtbl.fold (fun k v acc -> f acc k (value_of k v)) registry init | Some s -> let key_matches = starts_with (s ^ ".") in let rec fold_filter acc = function | [] -> acc - | (k,v) :: tl when key_matches k -> fold_filter (f acc k v) tl + | (k,v) :: tl when key_matches k -> + fold_filter (f acc k (value_of k v)) tl | _ :: tl -> fold_filter acc tl in fold_filter init (hashtbl_pairs registry) -let iter registry ?prefix f = fold registry ?prefix (fun _ k v -> f k v) () -let to_list registry ?prefix () = - fold registry ?prefix (fun acc k v -> (k, v) :: acc) [] +let iter registry ?prefix ?interpolate f = + fold registry ?prefix ?interpolate (fun _ k v -> f k v) () +let to_list registry ?prefix ?interpolate () = + fold registry ?prefix ?interpolate (fun acc k v -> (k, v) :: acc) [] let ls registry prefix = let prefix = prefix ^ "." in @@ -410,9 +525,12 @@ class registry ?path fname = method has = has _registry method unset = unset _registry method fold: - 'a. ?prefix:string -> ('a -> string -> string -> 'a) -> 'a -> 'a + 'a. + ?prefix:string -> ?interpolate: bool -> + ('a -> string -> string -> 'a) -> 'a -> 'a = - fold _registry + fun ?prefix ?interpolate f init -> + fold _registry ?prefix ?interpolate f init method iter = iter _registry method to_list = to_list _registry method ls = ls _registry @@ -455,7 +573,8 @@ let default_registry = Hashtbl.create magic_size let get = get default_registry let set = set default_registry let has = has default_registry -let fold ?prefix f init = fold default_registry ?prefix f init +let fold ?prefix ?interpolate f init = + fold default_registry ?prefix ?interpolate f init let iter = iter default_registry let to_list = to_list default_registry let ls = ls default_registry diff --git a/helm/ocaml/registry/helm_registry.mli b/helm/ocaml/registry/helm_registry.mli index a6b51271b..e108ff01d 100644 --- a/helm/ocaml/registry/helm_registry.mli +++ b/helm/ocaml/registry/helm_registry.mli @@ -108,9 +108,20 @@ val has: string -> bool * raise Key_not_found until the key will be redefined *) val unset: string -> unit -val fold: ?prefix:string -> ('a -> string -> string -> 'a) -> 'a -> 'a -val iter: ?prefix:string -> (string -> string -> unit) -> unit -val to_list: ?prefix:string -> unit -> (string * string) list + (** @param interpolate defaults to true *) +val fold: + ?prefix:string -> ?interpolate:bool -> + ('a -> string -> string -> 'a) -> 'a -> 'a + + (** @param interpolate defaults to true *) +val iter: + ?prefix:string -> ?interpolate:bool -> + (string -> string -> unit) -> unit + + (** @param interpolate defaults to true *) +val to_list: + ?prefix:string -> ?interpolate:bool -> + unit -> (string * string) list (** @param prefix key representing the section whose contents should be listed * @return section list * key list *) @@ -207,9 +218,13 @@ class registry: ?path: string list -> string -> method set: key:string -> value:string -> unit method has: string -> bool method unset: string -> unit - method fold: ?prefix:string -> ('a -> string -> string -> 'a) -> 'a -> 'a - method iter: ?prefix:string -> (string -> string -> unit) -> unit - method to_list: ?prefix:string -> unit -> (string * string) list + method fold: + ?prefix:string -> ?interpolate:bool -> + ('a -> string -> string -> 'a) -> 'a -> 'a + method iter: + ?prefix:string -> ?interpolate:bool -> (string -> string -> unit) -> unit + method to_list: + ?prefix:string -> ?interpolate:bool -> unit -> (string * string) list method ls: string -> string list * string list method get_string: string -> string method get_int: string -> int diff --git a/helm/ocaml/registry/test.ml b/helm/ocaml/registry/test.ml new file mode 100644 index 000000000..644b0f0da --- /dev/null +++ b/helm/ocaml/registry/test.ml @@ -0,0 +1,30 @@ +(* Copyright (C) 2004-2005, 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. + * + * 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;; +Helm_registry.load_from Sys.argv.(1); +Helm_registry.iter ~interpolate:false (fun k v -> printf "%s = %s\n" k v); +Helm_registry.save_to Sys.argv.(2) +