X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;ds=sidebyside;f=helm%2Focaml%2Fregistry%2Fhelm_registry.ml;h=3977bcf06d47ffc45a5de2c9d298809e5f041883;hb=9f60b3b0f4460aec52ec241037f6c475b421dd15;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..3977bcf06 100644 --- a/helm/ocaml/registry/helm_registry.ml +++ b/helm/ocaml/registry/helm_registry.ml @@ -25,14 +25,17 @@ 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 let get_next_validator_id = @@ -50,25 +53,37 @@ 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 ^ "$") - -let is_comment s = Pcre.pmatch ~rex:comment_rex s - -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 + (* 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 = Pcre.regexp valid_key_rex_raw +let dot_rex = Pcre.regexp "\\." +let spaces_rex = Pcre.regexp "\\s+" +let heading_spaces_rex = Pcre.regexp "^\\s+" +*) +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]+" + + (* 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,21 +94,57 @@ 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 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) + (* trailing blanks are removed per default by split *) +(* Pcre.split ~res:spaces_rex (Pcre.replace ~rex:heading_spaces_rex s) *) + Str.split spaces_rex (Str.global_replace heading_spaces_rex "" s) let string_of_string_list l = String.concat " " l let mk_get_set type_name (from_string: string -> 'a) (to_string: 'a -> string) = @@ -107,54 +158,68 @@ 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 save_to fname = + debug_print ("Saving configuration to " ^ fname); let oc = open_out fname in + output_string oc "\n"; + output_string oc "\n"; try Hashtbl.iter (fun key value -> - output_string oc (sprintf "%s = \"%s\"" key (escape value))) + fprintf oc " %s\n" key (escape value)) registry; + output_string oc ""; close_out oc with e -> close_out oc; raise e -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; - restore_registry backup; - raise e - let add_validator ~key ~validator ~descr = let id = get_next_validator_id () in Hashtbl.add validators key (validator, descr); id -(* - (* DEBUGGING *) +open Pxp_document +open Pxp_types +open Pxp_yacc + +let load_from = + let config = default_config in + let entry = `Entry_document [ `Extend_dtd_fully; `Parse_xml_decl ] in + fun fname -> + debug_print ("Loading configuration from " ^ fname); + let document = + parse_wfdocument_entity config (from_file fname) default_spec + in + let fill_registry () = + document#root#iter_nodes (fun n -> + try + (match n#node_type with + | T_element "value" -> + let key = n#required_string_attribute "key" in + let value = n#data in + set ~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 + fill_registry () + with exn -> + restore_registry backup; + raise exn + + (* DEBUGGING ONLY *) + let dump () = Hashtbl.iter (fun k v -> printf "%s = %s\n" k v) registry -*)