X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;ds=sidebyside;f=helm%2Focaml%2Fregistry%2Fhelm_registry.ml;h=5569165a3591c96821da3377140bcc8ee2966967;hb=43c726af72786e33196be859936e393ba69c9ae0;hp=30df896d66846dfee890251dfb163fb927f94740;hpb=cdc2c0c2ba2831239dcaad706bba8c73ab27723f;p=helm.git diff --git a/helm/ocaml/registry/helm_registry.ml b/helm/ocaml/registry/helm_registry.ml index 30df896d6..5569165a3 100644 --- a/helm/ocaml/registry/helm_registry.ml +++ b/helm/ocaml/registry/helm_registry.ml @@ -25,16 +25,22 @@ open Printf +let debug = false +let debug_print s = + if debug then prerr_endline ("Helm_registry debugging: " ^ s) + exception Malformed_key of string exception Key_not_found of string +exception Cyclic_definition of string exception Type_error of string * string * string (* expected type, value, msg *) -exception Parse_error of string * int (* file, lineno *) +exception Parse_error of string * int * int * string (* file, line, col, msg *) exception Invalid_value of (string * string) * string (* key, value, descr *) -exception Unescape_failure - type validator_id = int + (* root XML tag: used by save_to, ignored by load_from *) +let root_tag = "helm_registry" + let get_next_validator_id = let next_id = ref 0 in fun () -> @@ -50,25 +56,33 @@ let restore_registry backup = Hashtbl.clear registry; Hashtbl.iter (fun key value -> Hashtbl.replace registry key value) backup -let valid_key_rex_raw = "\\w+(\\.\\w+)*" -let config_line_raw = sprintf "\\s*(%s)\\s*=\\s*\"(.*)\"\\s*" valid_key_rex_raw -let comment_rex = Pcre.regexp "^\\s*(#|$)" -let valid_key_rex = Pcre.regexp ("^" ^ valid_key_rex_raw ^ "$") -let config_line_rex = Pcre.regexp ("^" ^ config_line_raw ^ "$") + (* as \\w but: + * - no sequences of '_' longer than 1 are permitted + * - no uppercase letter are permitted + *) +let valid_step_rex_raw = "[a-z0-9]+\\(_[a-z0-9]+\\)*" +let valid_key_rex_raw = + sprintf "%s\(\\.%s\)*" valid_step_rex_raw valid_step_rex_raw +let valid_key_rex = Str.regexp ("^" ^ valid_key_rex_raw ^ "$") +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 is_comment s = Pcre.pmatch ~rex:comment_rex s +let split s = + (* trailing blanks are removed per default by split *) + Str.split spaces_rex (Str.global_replace heading_spaces_rex "" s) +let merge l = String.concat " " l -let escape = String.escaped -let unescape = - let lexer = lazy (Genlex.make_lexer []) in - fun s -> - let tok_stream = Lazy.force lexer (Stream.of_string ("\"" ^ s ^ "\"")) in - match Stream.peek tok_stream with - | Some (Genlex.String s) -> s - | _ -> raise Unescape_failure + (* escapes for xml configuration file *) +let (escape, unescape) = + let (in_enc, out_enc) = (`Enc_utf8, `Enc_utf8) in + (Netencoding.Html.encode ~in_enc ~out_enc (), + Netencoding.Html.decode ~in_enc ~out_enc ~entity_base:`Xml ()) let key_is_valid key = - if not (Pcre.pmatch ~rex:valid_key_rex key) then +(* if not (Pcre.pmatch ~rex:valid_key_rex key) then *) + if not (Str.string_match valid_key_rex key 0) then raise (Malformed_key key) let value_is_valid ~key ~value = @@ -79,23 +93,55 @@ let value_is_valid ~key ~value = (Hashtbl.find_all validators key) let set' registry ~key ~value = + debug_print (sprintf "Setting %s = %s" key value); key_is_valid key; value_is_valid ~key ~value; Hashtbl.replace registry key value +let unset = Hashtbl.remove registry + +let env_var_of_key key = +(* Pcre.replace ~rex:dot_rex ~templ:"__" (String.uppercase key) *) + Str.global_replace dot_rex "__" (String.uppercase key) + let get key = - key_is_valid key; - try - Hashtbl.find registry key - with Not_found -> raise (Key_not_found key) + let rec aux stack key = + key_is_valid key; + if List.mem key stack then begin + let msg = (String.concat " -> " (List.rev stack)) ^ " -> " ^ key in + raise (Cyclic_definition msg) + end; + let registry_value = (* internal value *) + try + Some (Hashtbl.find registry key) + with Not_found -> None + in + let env_value = (* environment value *) + try + Some (Sys.getenv (env_var_of_key key)) + with Not_found -> None + in + let value = (* resulting value *) + match (registry_value, env_value) with + | Some reg, Some env -> env + | Some reg, None -> reg + | None, Some env -> env + | None, None -> raise (Key_not_found key) + in + interpolate (key :: stack) value + and interpolate stack value = + Str.global_substitute interpolated_key_rex + (fun s -> + let matched = Str.matched_string s in + (* "$(var)" -> "var" *) + let key = String.sub matched 2 (String.length matched - 3) in + aux stack key) + value + in + aux [] key let set = set' registry -let string_list_of_string s = - (* trailing blanks are removed per default by Pcre.split *) - Pcre.split ~pat:"\\s+" (Pcre.replace ~pat:"^\\s+" s) -let string_of_string_list l = String.concat " " l - let mk_get_set type_name (from_string: string -> 'a) (to_string: 'a -> string) = let getter key = let value = get key in @@ -107,54 +153,160 @@ let mk_get_set type_name (from_string: string -> 'a) (to_string: 'a -> string) = let setter ~key ~value = set ~key ~value:(to_string value) in (getter, setter) +let (get_string, set_string) = (get, set) let (get_int, set_int) = mk_get_set "int" int_of_string string_of_int let (get_float, set_float) = mk_get_set "float" float_of_string string_of_float -let (get_string_list, set_string_list) = - mk_get_set "string list" string_list_of_string string_of_string_list +let (get_bool, set_bool) = mk_get_set "bool" bool_of_string string_of_bool +let (get_string_list, set_string_list) = mk_get_set "string list" split merge -let save_to fname = - let oc = open_out fname in +let get_opt getter key = try + Some (getter key) + with Key_not_found _ -> None +let set_opt setter ~key ~value = + match value with + | None -> unset key + | Some value -> setter ~key ~value + +let add_validator ~key ~validator ~descr = + let id = get_next_validator_id () in + Hashtbl.add validators key (validator, descr); + id + +open Pxp_dtd +open Pxp_document +open Pxp_types +open Pxp_yacc + +let save_to = + let dtd = new dtd default_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 default_spec dtd "key" ["name", key] + in + let data = create_data_node default_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 default_spec dtd + "section" ["name", section] + in + node#append_node section_node; + section_node + in + aux next_node tl + in + aux root sections + in + fun fname -> + let xml_root = + create_element_node ~valcheck:false default_spec dtd "helm_registry" [] + in Hashtbl.iter (fun key value -> - output_string oc (sprintf "%s = \"%s\"" key (escape 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; - close_out oc - with e -> - close_out oc; - raise e + let outchan = (* let's write xml output to fname *) + if Unix.system "xmllint --version &> /dev/null" = Unix.WEXITED 0 then + (* xmllint available, use it! *) + Unix.open_process_out (sprintf + "xmllint --format --encode utf8 -o '%s' -" fname) + else + (* xmllint not available, write pxp ugly output directly to fname *) + open_out fname + in + xml_root#write (`Out_channel outchan) `Enc_utf8; + close_out outchan -let load_from fname = - let backup = backup_registry () in - Hashtbl.clear registry; - let ic = open_in fname in - let lineno = ref 0 in - try - while true do - incr lineno; - let line = input_line ic in - if not (is_comment line) then - let subs = Pcre.extract ~rex:config_line_rex line in - let (key, value) = (subs.(1), unescape subs.(3)) in - set ~key ~value - done - with - | End_of_file -> close_in ic - | Malformed_key _ | Unescape_failure | Not_found -> - restore_registry backup; - raise (Parse_error (fname, !lineno)) - | e -> - close_in ic; +let load_from_absolute = + let config = default_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 fname -> + debug_print ("Loading configuration from " ^ fname); + let document = + parse_wfdocument_entity config (from_file fname) default_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 ~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 () in + Hashtbl.clear registry; + try + aux [] document#root + with exn -> restore_registry backup; - raise e + raise exn -let add_validator ~key ~validator ~descr = - let id = get_next_validator_id () in - Hashtbl.add validators key (validator, descr); - id +let load_from ?path fname = + if Filename.is_relative fname then begin + let no_file_found = ref true in + let path = + match path with + | Some path -> path (* path given as argument *) + | None -> [ Sys.getcwd () ] (* no path given, try with cwd *) + in + List.iter + (fun dir -> + let conffile = dir ^ "/" ^ fname in + if Sys.file_exists conffile then begin + no_file_found := false; + load_from_absolute conffile + end) + path; + if !no_file_found then + failwith (sprintf + "Helm_registry.init: no configuration file named %s in [ %s ]" + fname (String.concat "; " path)) + end else + load_from_absolute fname + + (* DEBUGGING ONLY *) -(* - (* DEBUGGING *) let dump () = Hashtbl.iter (fun k v -> printf "%s = %s\n" k v) registry -*)