X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Focaml%2Fregistry%2Fhelm_registry.ml;h=35726d4c966868d20465c9374fb21bac1d1c8d29;hb=4167cea65ca58897d1a3dbb81ff95de5074700cc;hp=501f689d83f3edf7f2aca9b6a63162ada86d9167;hpb=1bb2cfafdfd2a3648ca8d2eac8b1952210fc5e65;p=helm.git diff --git a/helm/ocaml/registry/helm_registry.ml b/helm/ocaml/registry/helm_registry.ml index 501f689d8..35726d4c9 100644 --- a/helm/ocaml/registry/helm_registry.ml +++ b/helm/ocaml/registry/helm_registry.ml @@ -27,7 +27,7 @@ open Printf let debug = false let debug_print s = - if debug then prerr_endline ("Helm_registry debugging: " ^ s) + if debug then prerr_endline ("Helm_registry debugging: " ^ (Lazy.force s)) (** *) @@ -62,7 +62,6 @@ exception Key_not_found of string exception Cyclic_definition of string exception Type_error of string (* expected type, value, msg *) exception Parse_error of string * int * int * string (* file, line, col, msg *) -exception Invalid_value of (string * string) * string (* key, value, descr *) (* root XML tag: used by save_to, ignored by load_from *) let root_tag = "helm_registry" @@ -118,10 +117,11 @@ let key_is_valid key = if not (Str.string_match valid_key_rex key 0) then raise (Malformed_key key) -let set' registry ~key ~value = - debug_print (sprintf "Setting %s = %s" key value); +let set' ?(replace=false) registry ~key ~value = + debug_print (lazy(sprintf "Setting (replace: %b) %s = %s" replace key value)); key_is_valid key; - Hashtbl.add registry key value + let add_fun = if replace then Hashtbl.replace else Hashtbl.add in + add_fun registry key value let unset registry = Hashtbl.remove registry @@ -164,8 +164,6 @@ let get registry key = in List.map strip_blanks (aux [] key) -let set registry = set' registry - let has registry key = Hashtbl.mem registry key let get_typed registry unmarshaller key = @@ -173,7 +171,7 @@ let get_typed registry unmarshaller key = unmarshaller value let set_typed registry marshaller ~key ~value = - set registry ~key ~value:(marshaller value) + set' ~replace:true registry ~key ~value:(marshaller value) let get_opt registry unmarshaller key = try @@ -188,15 +186,24 @@ let get_opt_default registry unmarshaller ~default key = let set_opt registry marshaller ~key ~value = match value with | None -> unset registry key - | Some value -> set registry ~key ~value:(marshaller value) + | Some value -> set' ~replace:true registry ~key ~value:(marshaller value) let get_list registry unmarshaller key = try List.map unmarshaller (get registry key) with Key_not_found _ -> [] +let get_pair registry fst_unmarshaller snd_unmarshaller key = + let v = singleton (get registry key) in + match Str.split spaces_rex v with + | [fst; snd] -> fst_unmarshaller fst, snd_unmarshaller snd + | _ -> raise (Type_error "not a pair") + let set_list registry marshaller ~key ~value = - List.iter (fun v -> set registry ~key ~value:(marshaller v)) value + Hashtbl.remove registry key; + List.iter + (fun v -> set' ~replace:false registry ~key ~value:(marshaller v)) + value type xml_tree = | Cdata of string @@ -237,9 +244,9 @@ let xml_tree_of_registry registry = | _ -> assert false in Hashtbl.fold - (fun k v tree -> add_key ("helm_registry" :: (Str.split dot_RE k)) v tree) + (fun k v tree -> add_key ((Str.split dot_RE k)) v tree) registry - (Element ("helm_registry", [], [])) + (Element (root_tag, [], [])) let rec stream_of_xml_tree = function | Cdata s -> Xml.xml_cdata s @@ -257,17 +264,21 @@ let save_to registry fname = Xml.pp_to_outchan token_stream oc; close_out oc -let load_from_absolute registry fname = - let path = ref [] in (*
elements entered so far *) +let rec load_from_absolute ?path registry fname = + let _path = ref (match path with None -> [] | Some p -> p)in + (*
elements entered so far *) let in_key = ref false in (* have we entered a element? *) let cdata = ref "" in (* collected cdata (inside *) - let push_path name = path := name :: !path in - let pop_path () = path := List.tl !path in + 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", _ -> () + | "include", ["href", fname] -> + debug_print (lazy ("including file " ^ fname)); + load_from_absolute ~path:!_path registry fname | tag, _ -> raise (Parse_error (fname, ~-1, ~-1, (sprintf "unexpected element <%s> or wrong attribute set" tag))) @@ -276,12 +287,12 @@ let load_from_absolute registry fname = match tag with | "section" -> pop_path () | "key" -> - let key = String.concat "." (List.rev !path) in - set registry ~key ~value:!cdata; + let key = String.concat "." (List.rev !_path) in + set' registry ~key ~value:!cdata; cdata := ""; in_key := false; pop_path () - | "helm_registry" -> () + | "include" | "helm_registry" -> () | _ -> assert false in let character_data text = @@ -295,7 +306,7 @@ let load_from_absolute registry fname = } in let xml_parser = XmlPushParser.create_parser callbacks in let backup = backup_registry registry in - Hashtbl.clear registry; +(* if path = None then Hashtbl.clear registry; *) try XmlPushParser.parse xml_parser (`File fname) with exn -> @@ -378,7 +389,7 @@ let ls registry prefix = let default_registry = Hashtbl.create magic_size let get key = singleton (get default_registry key) -let set = set default_registry +let set = set' ~replace:true default_registry let has = has default_registry let fold ?prefix ?interpolate f init = fold default_registry ?prefix ?interpolate f init @@ -389,12 +400,14 @@ let get_typed unmarshaller = get_typed default_registry unmarshaller let get_opt unmarshaller = get_opt default_registry unmarshaller let get_opt_default unmarshaller = get_opt_default default_registry unmarshaller let get_list unmarshaller = get_list default_registry unmarshaller +let get_pair unmarshaller = get_pair default_registry unmarshaller let set_typed marshaller = set_typed default_registry marshaller let set_opt unmarshaller = set_opt default_registry unmarshaller let set_list marshaller = set_list default_registry marshaller let unset = unset default_registry let save_to = save_to default_registry let load_from = load_from default_registry +let clear () = Hashtbl.clear default_registry let get_string = get_typed string let get_int = get_typed int