Skip to content

GitLab

Commit c272c7ec authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2005-02-18 17:36:34 by afrisch] Schema and namespaces 

Original author: afrisch
Date: 2005-02-18 17:36:35+00:00
parent 6a14fe70
Hide whitespace changes
Inline Side-by-side
compile/lambda.ml
View file @ c272c7ec
......@@ -56,7 +56,7 @@ type expr =
| Transform of expr * branches
| Xtrans of expr * branches
| Try of expr * branches
| Validate of expr * schema_component_kind * string * U.t
| Validate of expr * schema_component_kind * string * Ns.qname
| RemoveField of expr * label
| Dot of expr * label
| Ref of expr * Types.Node.t
......@@ -191,7 +191,7 @@ module Put = struct
expr s e;
serialize_schema_component_kind s k;
string s sch;
U.serialize s t
Ns.QName.serialize s t
(* assert false (* TODO:Need to store a pointer to the schema ... *) *)
| RemoveField (e,l) ->
bits nbits s 14;
......@@ -315,7 +315,7 @@ module Get = struct
let e = expr s in
let k = deserialize_schema_component_kind s in
let sch = string s in
let t = U.deserialize s in
let t = Ns.QName.deserialize s in
Validate (e,k,sch,t)
| 14 ->
let e = expr s in
......
compile/lambda.mli
View file @ c272c7ec
......@@ -29,7 +29,7 @@ type expr =
| Transform of expr * branches
| Xtrans of expr * branches
| Try of expr * branches
| Validate of expr * schema_component_kind * string * U.t
| Validate of expr * schema_component_kind * string * Ns.qname
| RemoveField of expr * label
| Dot of expr * label
| Ref of expr * Types.Node.t
......
driver/cduce.ml
View file @ c272c7ec
......@@ -258,8 +258,9 @@ let directive ppf tenv cenv = function
Typer.dump_type ppf tenv name;
flush_ppf ppf
| `Print_schema_type schema_ref ->
Typer.dump_schema_type ppf tenv schema_ref;
flush_ppf ppf
assert false
(* Typer.dump_schema_type ppf tenv schema_ref;
flush_ppf ppf *)
| `Reinit_ns ->
Typer.set_ns_table_for_printer tenv
| `Help ->
......
misc/ns.ml
View file @ c272c7ec
......@@ -21,6 +21,10 @@ module P = Pool.Make(U)
include P
let empty = mk empty_str
let xml_ns = mk (U.mk "http://www.w3.org/XML/1998/namespace")
let xsd_ns = mk (U.mk "http://www.w3.org/2001/XMLSchema")
let xsi_ns = mk (U.mk "http://www.w3.org/2001/XMLSchema-instance")
let mk_ascii s = mk (U.mk s)
module Table = Map.Make(U)
......@@ -52,7 +56,11 @@ let deserialize_table s =
let global_hints = State.ref "Ns.prefixes" (Hashtbl.create 63)
let empty_table =
Table.add empty_str empty (Table.add (U.mk "xml") xml_ns Table.empty)
List.fold_left
(fun table (pr,ns) -> Table.add (U.mk pr) ns table)
Table.empty
["", empty; "xml", xml_ns; "xsd", xsd_ns; "xsi", xsi_ns]
let add_prefix pr ns table =
if (U.get_str pr <> "") then Hashtbl.add !global_hints ns pr;
Table.add pr ns table
......
schema/schema_builtin.ml
View file @ c272c7ec
......@@ -12,7 +12,8 @@ open Schema_types
(** {2 Aux/Misc stuff} *)
let add_xsd_prefix s = Utf8.mk ("xsd:"^s)
let xsd = Schema_xml.xsd
let add_xsd_prefix s = (xsd, Utf8.mk s)
let unsupported =
List.map (fun s -> add_xsd_prefix s)
......@@ -50,8 +51,8 @@ let char_of_hex =
let strip_parens s = Pcre.replace ~pat:"[()]" s
let add_limits s = "^" ^ s ^ "$"
exception Schema_builtin_error of Utf8.t
let simple_type_error name = raise (Schema_builtin_error (add_xsd_prefix name))
exception Schema_builtin_error of string
let simple_type_error name = raise (Schema_builtin_error name)
let qualify s = (Ns.empty, Encodings.Utf8.mk s)
......@@ -402,12 +403,14 @@ let validate_anyURI s =
(** {2 API backend} *)
let builtins = Hashtbl.create 50
let reg name spec = Hashtbl.add builtins (add_xsd_prefix name) spec
module QTable = Hashtbl.Make(Ns.QName)
let builtins = QTable.create 50
let reg name spec = QTable.add builtins (add_xsd_prefix name) spec
let alias alias name =
let (alias, name) = (add_xsd_prefix alias, add_xsd_prefix name) in
Hashtbl.add builtins alias
(let (st_def, descr, validator) = Hashtbl.find builtins name in
QTable.add builtins alias
(let (st_def, descr, validator) = QTable.find builtins name in
let new_def =
match st_def with
| Primitive _ -> Primitive alias
......@@ -417,7 +420,7 @@ let alias alias name =
(new_def, descr, validator))
let restrict' name basename new_facets =
let (name, basename) = (add_xsd_prefix name, add_xsd_prefix basename) in
let (base, _, _) = Hashtbl.find builtins basename in
let (base, _, _) = QTable.find builtins basename in
let variety = variety_of_simple_type_definition base in
let facets =
merge_facets (facets_of_simple_type_definition base) new_facets
......@@ -425,7 +428,7 @@ let restrict' name basename new_facets =
Derived (Some name, variety, facets, ref (Simple base))
let list' name itemname =
let (name, itemname) = (add_xsd_prefix name, add_xsd_prefix itemname) in
let (base, _, _) = Hashtbl.find builtins itemname in
let (base, _, _) = QTable.find builtins itemname in
let base = ref (Simple base) in
Derived (Some name, List base, no_facets, base)
......@@ -563,7 +566,7 @@ let null_value = {
}
let string_of_time_type fields =
let fail () = raise (Schema_builtin_error (Utf8.mk "")) in
let fail () = raise (Schema_builtin_error "") in
let parse_int = function Value.Integer i -> i | _ -> fail () in
let parse_timezone v =
let fields =
......@@ -694,11 +697,11 @@ let string_of_time_type fields =
(** {2 API} *)
let is_builtin = Hashtbl.mem builtins
let is_builtin = QTable.mem builtins
let iter_builtin f =
Hashtbl.iter (fun _ (type_def, _, _) -> f type_def) builtins
QTable.iter (fun _ (type_def, _, _) -> f type_def) builtins
let lookup name = Hashtbl.find builtins name
let lookup name = QTable.find builtins name
let fst (x,_,_) = x
let snd (_,y,_) = y
......
schema/schema_builtin.mli
View file @ c272c7ec
......@@ -3,13 +3,13 @@ open Encodings
(** all schema simple type names used in this API are prefixed with
* Schema_xml.xsd_prefix *)
exception Schema_builtin_error of Utf8.t
exception Schema_builtin_error of string
val is_builtin: Utf8.t -> bool
val get_builtin: Utf8.t -> Schema_types.simple_type_definition
val is_builtin: Ns.QName.t -> bool
val get_builtin: Ns.QName.t -> Schema_types.simple_type_definition
val iter_builtin: (Schema_types.simple_type_definition -> unit) -> unit
val cd_type_of_builtin: Utf8.t -> Types.descr
val cd_type_of_builtin: Ns.QName.t -> Types.descr
(** validate_builtin <builtin> <string>
* validates <string> against builtin type <builtin> and return the resulting
......@@ -17,7 +17,7 @@ val cd_type_of_builtin: Utf8.t -> Types.descr
* @raise Schema_builtin_error [name] in case of validation error, where
* [name] is the name of a schema built in type prefixed with
* Schema_xml.xsd_prefix *)
val validate_builtin: Utf8.t -> Utf8.t -> Value.t
val validate_builtin: Ns.QName.t -> Utf8.t -> Value.t
val string_of_time_type: (Ns.qname * Value.t) list -> Utf8.t
schema/schema_common.ml
View file @ c272c7ec
......@@ -4,6 +4,8 @@ open Encodings
open Schema_pcre
open Schema_types
let xsd = Schema_xml.xsd
let no_facets = {
length = None;
minLength = None;
......@@ -71,7 +73,7 @@ let rec variety_of_simple_type_definition = function
let get_simple_type = function
| { contents = Simple c } -> c
| { contents = AnyType } -> Primitive (Utf8.mk "xsd:anySimpleType")
| { contents = AnyType } -> Primitive (xsd,Utf8.mk "anySimpleType")
| _ -> assert false
let rec normalize_simple_type = function
......@@ -93,7 +95,7 @@ let name_of_complex_type_definition = function
| { ct_name = Some name } -> name
| _ -> raise (Invalid_argument "anonymous complex type definition")
let name_of_type_definition = function
| AnyType -> Encodings.Utf8.mk "xsd:anyType"
| AnyType -> (xsd, Utf8.mk "anyType")
| Simple st -> name_of_simple_type_definition st
| Complex ct -> name_of_complex_type_definition ct
let name_of_attribute_declaration a = a.attr_name
......@@ -141,7 +143,7 @@ let rec normalize_white_space =
in
pcre_replace ~rex:margins_RE ~templ:(Utf8.mk "$1") s'
let anySimpleType = Primitive (Encodings.Utf8.mk "xsd:anySimpleType")
let anySimpleType = Primitive (xsd, Utf8.mk "anySimpleType")
let anyType = AnyType
let first_of_particle (_, _, _, first) = first
......@@ -158,7 +160,7 @@ let first_of_model_group = function
aux particles
let rec is_in_first tag = function
| [] -> false
| Some tag' :: rest when Utf8.equal tag' tag -> true
| Some tag' :: rest when Ns.QName.equal tag' tag -> true
| _ :: rest -> is_in_first tag rest
let get_interval facets =
......@@ -191,13 +193,13 @@ let get_interval facets =
let print_simple_type fmt = function
| Primitive name -> Format.fprintf fmt "%a" Encodings.Utf8.dump name
| Primitive name -> Format.fprintf fmt "%a" Ns.QName.print name
| Derived (Some name, _, _, _) ->
Format.fprintf fmt "%a'" Encodings.Utf8.dump name
| Derived (None, _, _, _) -> Format.fprintf fmt "unnamed'"
Format.fprintf fmt "%a'" Ns.QName.print name
| Derived (None, _, _, _) -> Format.fprintf fmt "unnamed"
let print_complex_type fmt = function
| { ct_uid = id; ct_name = Some name } ->
Format.fprintf fmt "%d:%a" id Encodings.Utf8.dump name
Format.fprintf fmt "%d:%a" id Ns.QName.print name
| { ct_uid = id } ->
Format.fprintf fmt "%d:unnamed'" id
let print_type fmt = function
......@@ -205,20 +207,20 @@ let print_type fmt = function
| Simple t -> Format.fprintf fmt "S:%a" print_simple_type t
| Complex t -> Format.fprintf fmt "C:%a" print_complex_type t
let print_attribute fmt { attr_name = name; attr_typdef = t } =
Format.fprintf fmt "@@%a:%a" Utf8.dump name print_simple_type
Format.fprintf fmt "@@%a:%a" Ns.QName.print name print_simple_type
(get_simple_type t)
let print_element fmt { elt_uid = id; elt_name = name } =
Format.fprintf fmt "E:%d:<%a>" id Utf8.dump name
Format.fprintf fmt "E:%d:<%a>" id Ns.QName.print name
let print_attributes fmt = List.iter (Format.fprintf fmt "%a" print_attribute)
let print_attribute_group fmt ag =
Format.fprintf fmt "{agroup:%a}" Utf8.dump ag.ag_name
Format.fprintf fmt "{agroup:%a}" Ns.QName.print ag.ag_name
let print_model_group fmt mg =
Format.fprintf fmt "{mgroup:%a}" Utf8.dump mg.mg_name
Format.fprintf fmt "{mgroup:%a}" Ns.QName.print mg.mg_name
let print_schema fmt schema =
let defined_types = (* filter out built-in types *)
List.filter
(fun def -> not (Schema_xml.has_xsd_prefix (name_of_type_definition def)))
schema.types
List.filter (fun t ->
let (ns,_) = name_of_type_definition t in
not (Ns.equal ns xsd)) schema.types
in
if defined_types <> [] then begin
Format.fprintf fmt "Types: ";
......@@ -252,41 +254,29 @@ let print_schema fmt schema =
end
let get_type name schema =
let get_qual name table get_name =
List.find
(fun x ->
try
name_of_type_definition x = name
try Ns.QName.equal (get_name x) name
with Invalid_argument _ -> false)
schema.types
let get_attribute name schema =
table
let get_unqual name table get_name =
List.find
(fun x ->
try
name_of_attribute_declaration x = name
try Utf8.equal (snd (get_name x)) name
with Invalid_argument _ -> false)
schema.attributes
table
let get_type name schema = get_qual name schema.types name_of_type_definition
let get_attribute name schema =
get_qual name schema.attributes name_of_attribute_declaration
let get_element name schema =
List.find
(fun x ->
try
name_of_element_declaration x = name
with Invalid_argument _ -> false)
schema.elements
get_qual name schema.elements name_of_element_declaration
let get_attribute_group name schema =
List.find
(fun x ->
try
name_of_attribute_group_definition x = name
with Invalid_argument _ -> false)
schema.attribute_groups
get_qual name schema.attribute_groups name_of_attribute_group_definition
let get_model_group name schema =
List.find
(fun x ->
try
name_of_model_group_definition x = name
with Invalid_argument _ -> false)
schema.model_groups
get_qual name schema.model_groups name_of_model_group_definition
(* policy for unqualified schema component resolution. The order should
* be consistent with Typer.find_schema_descr *)
......@@ -308,6 +298,37 @@ let get_component kind name schema =
| Some `Model_group -> mod_group ()
| None -> tries [ elt; typ; att; att_group; mod_group ]
let get_type name schema =
get_unqual name schema.types name_of_type_definition
let get_attribute name schema =
get_unqual name schema.attributes name_of_attribute_declaration
let get_element name schema =
get_unqual name schema.elements name_of_element_declaration
let get_attribute_group name schema =
get_unqual name schema.attribute_groups name_of_attribute_group_definition
let get_model_group name schema =
get_unqual name schema.model_groups name_of_model_group_definition
(* policy for unqualified schema component resolution. The order should
* be consistent with Typer.find_schema_descr *)
let get_unqual_component kind name schema =
let rec tries = function
| [] -> raise Not_found
| hd :: tl -> (try hd () with Not_found -> tries tl)
in
let elt () = Element (get_element name schema) in
let typ () = Type (get_type name schema) in
let att () = Attribute (get_attribute name schema) in
let att_group () = Attribute_group (get_attribute_group name schema) in
let mod_group () = Model_group (get_model_group name schema) in
match kind with
| Some `Element -> elt ()
| Some `Type -> typ ()
| Some `Attribute -> att ()
| Some `Attribute_group -> att_group ()
| Some `Model_group -> mod_group ()
| None -> tries [ elt; typ; att; att_group; mod_group ]
let string_of_component_kind (kind: component_kind) =
match kind with
| Some `Type -> "type"
......
schema/schema_common.mli
View file @ c272c7ec
......@@ -25,15 +25,15 @@ val print_complex_type : Format.formatter -> complex_type_definition -> unit
val get_simple_type: type_ref -> simple_type_definition
val name_of_element_declaration : element_declaration -> Utf8.t
val name_of_type_definition : type_definition -> Utf8.t
val name_of_simple_type_definition : simple_type_definition -> Utf8.t
val name_of_complex_type_definition : complex_type_definition -> Utf8.t
val name_of_attribute_declaration : attribute_declaration -> Utf8.t
val name_of_attribute_use : attribute_use -> Utf8.t
val name_of_attribute_group_definition : attribute_group_definition -> Utf8.t
val name_of_model_group_definition : model_group_definition -> Utf8.t
val name_of_particle : particle -> Utf8.t
val name_of_element_declaration : element_declaration -> Ns.qname
val name_of_type_definition : type_definition -> Ns.qname
val name_of_simple_type_definition : simple_type_definition -> Ns.qname
val name_of_complex_type_definition : complex_type_definition -> Ns.qname
val name_of_attribute_declaration : attribute_declaration -> Ns.qname
val name_of_attribute_use : attribute_use -> Ns.qname
val name_of_attribute_group_definition : attribute_group_definition -> Ns.qname
val name_of_model_group_definition : model_group_definition -> Ns.qname
val name_of_particle : particle -> Ns.qname
val string_of_component_kind : component_kind -> string
......@@ -43,13 +43,16 @@ val simple_type_of_type : type_definition -> simple_type_definition
val complex_type_of_type : type_definition -> complex_type_definition
val content_type_of_type : type_definition -> content_type
val get_type: Utf8.t -> schema -> type_definition
val get_attribute: Utf8.t -> schema -> attribute_declaration
val get_element: Utf8.t -> schema -> element_declaration
val get_attribute_group: Utf8.t -> schema -> attribute_group_definition
val get_model_group: Utf8.t -> schema -> model_group_definition
(*
val get_type: Ns.qname -> schema -> type_definition
val get_attribute: Ns.qname -> schema -> attribute_declaration
val get_element: Ns.qname -> schema -> element_declaration
val get_attribute_group: Ns.qname -> schema -> attribute_group_definition
val get_model_group: Ns.qname -> schema -> model_group_definition
*)
val get_component: component_kind -> Utf8.t -> schema -> component
val get_component: component_kind -> Ns.qname -> schema -> component
val get_unqual_component: component_kind -> Utf8.t -> schema -> component
val iter_types: schema -> (type_definition -> unit) -> unit
val iter_attributes: schema -> (attribute_declaration -> unit) -> unit
......@@ -60,7 +63,7 @@ val iter_model_groups: schema -> (model_group_definition -> unit) -> unit
val first_of_particle: particle -> first
val first_of_model_group: model_group -> first
val is_in_first: Utf8.t -> first -> bool
val is_in_first: Ns.qname -> first -> bool
val nullable: particle -> bool
(** {2 Facets} *)
......
schema/schema_parser.ml
View file @ c272c7ec
......@@ -7,19 +7,23 @@ open Schema_types
open Schema_validator
open Schema_xml
module QTable = Hashtbl.Make(Ns.QName)
let validation_error s = raise (XSD_validation_error s)
let xsd = Schema_xml.xsd
let fake_type_def =
Complex
{ ct_uid = -1;
ct_name = Some (Utf8.mk " FAKE TYP ");
ct_name = Some (xsd, Utf8.mk " FAKE TYP ");
ct_typdef = AnyType;
ct_deriv = `Restriction;
ct_attrs = [];
ct_content = CT_empty }
let fake_elt_decl =
{ elt_uid = -2;
elt_name = Utf8.mk " FAKE ELT ";
elt_name = (xsd, Utf8.mk " FAKE ELT ");
elt_typdef = ref fake_type_def;
elt_cstr = None }
let is_fake_type_def = (==) fake_type_def
......@@ -52,14 +56,14 @@ let split s = pcre_split ~rex:space_RE s
let unqualify s = snd (Ns.split_qname s)
let hashtbl_deref tbl = Hashtbl.fold (fun _ v acc -> !v :: acc) tbl []
let hashtbl_values tbl = Hashtbl.fold (fun _ v acc -> v :: acc) tbl []
let hashtbl_deref tbl = QTable.fold (fun _ v acc -> !v :: acc) tbl []
let hashtbl_values tbl = QTable.fold (fun _ v acc -> v :: acc) tbl []
let parse_facets base n =
let validate_base_type v =
lazy (Schema_validator.validate_simple_type (get_simple_type base) v) in
let validate_nonNegativeInteger =
Schema_builtin.validate_builtin (Utf8.mk "xsd:nonNegativeInteger")
Schema_builtin.validate_builtin (xsd, Utf8.mk "nonNegativeInteger")
in
let aux facets n tag =
let fixed = _is_attr "fixed" n "true" in
......@@ -144,148 +148,116 @@ let find_particles n =
let find_particle n =
first n _may_elem ["xsd:all"; "xsd:choice"; "xsd:group"; "xsd:sequence"]
let register_builtins typs =
Schema_builtin.iter_builtin
(fun st_def ->
let type_def = Simple st_def in
let name = name_of_type_definition type_def in
Hashtbl.replace typs name (ref type_def));
Hashtbl.replace typs (Utf8.mk "xsd:anyType") (ref AnyType)
QTable.replace typs name (ref type_def));
QTable.replace typs (xsd, Utf8.mk "anyType") (ref AnyType)
(* Main parsing function *)
let schema_of_uri uri =
let nsman = new Pxp_dtd.namespace_manager in
List.iter
(fun (p, ns) ->nsman#add_namespace (Utf8.get_str p) (Utf8.get_str ns))
Schema_xml.schema_ns_prefixes;
let root = node_of_uri uri in
let orig_ns = Hashtbl.create 17 in
let register_ns rt =
List.iter
(fun (prefix,uri) ->
if prefix <> "" then begin
Hashtbl.add orig_ns prefix uri;
ignore (nsman#lookup_or_add_namespace prefix uri)
end)
(_namespaces rt)
in
register_ns root;
let qualify,targetNamespace =
match _may_attr "targetNamespace" root with
| Some ns ->
let pr = nsman#lookup_or_add_namespace "target" (Utf8.get_str ns) in
let pr = Utf8.mk (pr ^ ":") in
(fun name -> Utf8.concat pr name),
Ns.mk ns
| None ->
(fun name -> name), Ns.empty
in
let typs = Hashtbl.create 17
and attrs = Hashtbl.create 17
and elts = Hashtbl.create 17
and attr_groups = Hashtbl.create 17
and model_groups = Hashtbl.create 17 in
let typs = QTable.create 17 in
let elts = QTable.create 17 in
let attrs= QTable.create 17 in
let attr_groups = QTable.create 17 in
let model_groups = QTable.create 17 in
register_builtins typs;
let fix_namespace s =
match Ns.split_qname s with
| "", base -> qualify base
| prefix, base ->
(try
let orig_uri = Hashtbl.find orig_ns prefix in
let new_prefix = nsman#get_normprefix orig_uri in
Utf8.concat (Utf8.mk (new_prefix ^ ":")) base
with Not_found ->
validation_error ("Can't resolve: " ^ Utf8.get_str s))
let attr_elems = QTable.create 17
and attr_group_elems = QTable.create 17
and model_group_elems = QTable.create 17 in
let resolve k t1 t2 f qname =
try QTable.find t1 qname
with Not_found ->
let node =
try QTable.find t2 qname
with Not_found ->
validation_error ("Can't find declaration for " ^ k ^ " " ^
Ns.QName.to_string qname)
in
let decl = f node in
QTable.replace t1 qname decl;
decl
in
let todo = ref [] in
let roots = ref [ ] in
let find_global_component tag_pred name err =
let basename = Utf8.get_str (snd (Ns.split_qname name)) in
let sel n = (_has_tag n tag_pred) && (_is_attr "name" n basename) in
let rec aux = function
| [] ->
validation_error ("Can't find declaration for " ^ err ^ " " ^
Utf8.get_str name)
| hd::tl -> (try _find sel hd with Not_found -> aux tl)
let rec parse_uri uri =
let root = node_of_uri uri in
let targetNamespace =
match _may_attr "targetNamespace" root with
| Some ns -> Ns.mk ns
| None -> Ns.empty
in
aux !roots
in
let attributeFormDefault =
_is_attr "attributeFormDefault" root "qualified" in
let elementFormDefault =
_is_attr "elementFormDefault" root "qualified" in
let parse_root root =
let may_name n =
match _may_attr "name" n with
| Some local -> Some (targetNamespace,local)
| None -> None in
let get_name n = (targetNamespace, _attr "name" n) in
let rec resolve_typ name =
try Hashtbl.find typs (fix_namespace name)
let rec resolve_typ qname =
try QTable.find typs qname
with Not_found ->
failwith ("Cannot find type " ^ (Utf8.to_string name))
failwith ("Cannot find type " ^ (Ns.QName.to_string qname))
and resolve_simple_typ name =
resolve_typ name
and resolve_simple_typ qname =
resolve_typ qname
and resolve_elt name =
try Hashtbl.find elts (fix_namespace name)