Skip to content

GitLab

Commit 6481d59a authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2005-02-18 12:12:08 by afrisch] include schema 

Original author: afrisch
Date: 2005-02-18 12:12:09+00:00
parent 64643824
Show whitespace changes
Inline Side-by-side
Makefile.distrib
View file @ 6481d59a
......@@ -158,10 +158,10 @@ OBJECTS = \
compile/lambda.cmo \
runtime/value.cmo \
\
parser/location.cmo \
parser/location.cmo parser/url.cmo \
$(SCHEMA_OBJS) \
\
parser/url.cmo parser/ulexer.cmo parser/ast.cmo parser/parser.cmo \
parser/ulexer.cmo parser/ast.cmo parser/parser.cmo \
\
types/externals.cmo \
typing/typed.cmo typing/typer.cmo \
......
depend
View file @ 6481d59a
......@@ -86,16 +86,20 @@ runtime/value.cmo: types/atoms.cmi types/builtin_defs.cmi types/chars.cmi \
runtime/value.cmx: types/atoms.cmx types/builtin_defs.cmx types/chars.cmx \
misc/encodings.cmx types/ident.cmx types/intervals.cmx compile/lambda.cmx \
misc/ns.cmx types/sequence.cmx types/types.cmx runtime/value.cmi
parser/location.cmo: misc/html.cmi parser/location.cmi
parser/location.cmx: misc/html.cmx parser/location.cmi
parser/url.cmo: parser/location.cmi parser/url.cmi
parser/url.cmx: parser/location.cmx parser/url.cmi
schema/schema_pcre.cmo: misc/encodings.cmi schema/schema_pcre.cmi
schema/schema_pcre.cmx: misc/encodings.cmx schema/schema_pcre.cmi
schema/schema_types.cmo: misc/encodings.cmi types/intervals.cmi misc/ns.cmi \
runtime/value.cmi schema/schema_types.cmi
schema/schema_types.cmx: misc/encodings.cmx types/intervals.cmx misc/ns.cmx \
runtime/value.cmx schema/schema_types.cmi
schema/schema_xml.cmo: misc/encodings.cmi misc/ns.cmi schema/schema_pcre.cmi \
schema/schema_xml.cmi
schema/schema_xml.cmx: misc/encodings.cmx misc/ns.cmx schema/schema_pcre.cmx \
schema/schema_xml.cmi
schema/schema_xml.cmo: misc/encodings.cmi parser/location.cmi \
schema/schema_pcre.cmi parser/url.cmi schema/schema_xml.cmi
schema/schema_xml.cmx: misc/encodings.cmx parser/location.cmx \
schema/schema_pcre.cmx parser/url.cmx schema/schema_xml.cmi
schema/schema_common.cmo: types/atoms.cmi misc/encodings.cmi \
types/intervals.cmi misc/ns.cmi schema/schema_pcre.cmi \
schema/schema_types.cmi schema/schema_xml.cmi runtime/value.cmi \
......@@ -107,13 +111,13 @@ schema/schema_common.cmx: types/atoms.cmx misc/encodings.cmx \
schema/schema_builtin.cmo: types/atoms.cmi types/builtin_defs.cmi \
misc/encodings.cmi types/intervals.cmi misc/ns.cmi \
schema/schema_common.cmi schema/schema_pcre.cmi schema/schema_types.cmi \
schema/schema_xml.cmi types/sequence.cmi types/types.cmi \
runtime/value.cmi schema/schema_builtin.cmi
types/sequence.cmi types/types.cmi runtime/value.cmi \
schema/schema_builtin.cmi
schema/schema_builtin.cmx: types/atoms.cmx types/builtin_defs.cmx \
misc/encodings.cmx types/intervals.cmx misc/ns.cmx \
schema/schema_common.cmx schema/schema_pcre.cmx schema/schema_types.cmx \
schema/schema_xml.cmx types/sequence.cmx types/types.cmx \
runtime/value.cmx schema/schema_builtin.cmi
types/sequence.cmx types/types.cmx runtime/value.cmx \
schema/schema_builtin.cmi
schema/schema_validator.cmo: types/atoms.cmi misc/encodings.cmi \
types/intervals.cmi misc/ns.cmi schema/schema_builtin.cmi \
schema/schema_common.cmi schema/schema_pcre.cmi schema/schema_types.cmi \
......@@ -125,15 +129,11 @@ schema/schema_validator.cmx: types/atoms.cmx misc/encodings.cmx \
schema/schema_parser.cmo: misc/encodings.cmi types/intervals.cmi misc/ns.cmi \
schema/schema_builtin.cmi schema/schema_common.cmi schema/schema_pcre.cmi \
schema/schema_types.cmi schema/schema_validator.cmi schema/schema_xml.cmi \
runtime/value.cmi schema/schema_parser.cmi
parser/url.cmi runtime/value.cmi schema/schema_parser.cmi
schema/schema_parser.cmx: misc/encodings.cmx types/intervals.cmx misc/ns.cmx \
schema/schema_builtin.cmx schema/schema_common.cmx schema/schema_pcre.cmx \
schema/schema_types.cmx schema/schema_validator.cmx schema/schema_xml.cmx \
runtime/value.cmx schema/schema_parser.cmi
parser/location.cmo: misc/html.cmi parser/location.cmi
parser/location.cmx: misc/html.cmx parser/location.cmi
parser/url.cmo: parser/location.cmi parser/url.cmi
parser/url.cmx: parser/location.cmx parser/url.cmi
parser/url.cmx runtime/value.cmx schema/schema_parser.cmi
parser/ulexer.cmo: parser/ulexer.cmi
parser/ulexer.cmx: parser/ulexer.cmi
parser/ast.cmo: types/builtin_defs.cmi types/chars.cmi types/ident.cmo \
......@@ -274,6 +274,10 @@ ocamliface/mlstub.cmx: types/atoms.cmx types/builtin_defs.cmx \
driver/librarian.cmx parser/location.cmx ocamliface/mltypes.cmx \
misc/ns.cmx types/sequence.cmx typing/typer.cmx types/types.cmx \
ocamliface/mlstub.cmi
parser/cduce_netclient.cmo: driver/config.cmi parser/location.cmi \
parser/url.cmi
parser/cduce_netclient.cmx: driver/config.cmx parser/location.cmx \
parser/url.cmx
runtime/cduce_pxp.cmo: driver/config.cmi runtime/load_xml.cmi \
parser/location.cmi parser/url.cmi runtime/cduce_pxp.cmi
runtime/cduce_pxp.cmx: driver/config.cmx runtime/load_xml.cmx \
......@@ -369,17 +373,17 @@ compile/lambda.cmi: types/ident.cmo misc/ns.cmi types/patterns.cmi \
runtime/value.cmi: types/atoms.cmi types/chars.cmi misc/encodings.cmi \
types/ident.cmo types/intervals.cmi compile/lambda.cmi misc/ns.cmi \
types/types.cmi
parser/location.cmi: misc/html.cmi
schema/schema_pcre.cmi: misc/encodings.cmi
schema/schema_types.cmi: misc/encodings.cmi types/intervals.cmi misc/ns.cmi \
runtime/value.cmi
schema/schema_xml.cmi: misc/encodings.cmi misc/ns.cmi
schema/schema_xml.cmi: misc/encodings.cmi
schema/schema_common.cmi: misc/encodings.cmi types/intervals.cmi \
schema/schema_types.cmi runtime/value.cmi
schema/schema_builtin.cmi: misc/encodings.cmi misc/ns.cmi \
schema/schema_types.cmi types/types.cmi runtime/value.cmi
schema/schema_validator.cmi: schema/schema_types.cmi runtime/value.cmi
schema/schema_parser.cmi: schema/schema_types.cmi schema/schema_xml.cmi
parser/location.cmi: misc/html.cmi
schema/schema_parser.cmi: schema/schema_types.cmi
parser/parser.cmi: parser/ast.cmo
types/externals.cmi: types/types.cmi
typing/typer.cmi: parser/ast.cmo misc/custom.cmo types/ident.cmo \
......
parser/url.ml
View file @ 6481d59a
......@@ -20,11 +20,46 @@ let no_load_url s =
let load_url = ref no_load_url
let process s =
type kind = File of string | Uri of string | String of string
let kind s =
match start_with s "string://" with
| None ->
Location.protect_op "load_xml";
if is_url s then Url (!load_url s)
else Filename s
| Some s ->
Url s
| None -> if is_url s then Uri s else File s
| Some s -> String s
let local s1 s2 =
match (kind s1, kind s2) with
| File _, File _ ->
let url1 = Neturl.file_url_of_local_path s1 in
let url2 =
Neturl.parse_url
~base_syntax:(Neturl.url_syntax_of_url url1)
s2 in
Neturl.local_path_of_file_url(
Neturl.ensure_absolute_url ~base:url1 url2
)
| _, (String _ | Uri _) | (String _, File _) ->
s2
| Uri _, File _ ->
let url1 = Neturl.parse_url s1 in
let url2 =
Neturl.parse_url
~base_syntax:(Neturl.url_syntax_of_url url1)
s2 in
Neturl.string_of_url (Neturl.ensure_absolute_url ~base:url1 url2)
(*
match (kind s1, kind s2) with
| File _, File _ ->
Filename.concat s1 s2
| _, (String _ | Uri _) | (String _, File _) ->
s2
| Uri _, File _ ->
if (s1 = "") || (s1.[String.length s1 - 1] = '/') then (s1 ^ s2)
else (s1 ^ "/" ^ s2)
*)
let process s =
match kind s with
| File s -> Location.protect_op "loading file"; Filename s
| Uri s -> Location.protect_op "fetching external URI"; Url (!load_url s)
| String s -> Url s
parser/url.mli
View file @ 6481d59a
......@@ -6,6 +6,6 @@ type url = Filename of string | Url of string
val process: string -> url
val local: string -> string -> string
val load_url: (string -> string) ref
schema/schema_parser.ml
View file @ 6481d59a
......@@ -153,20 +153,25 @@ let register_builtins typs =
Hashtbl.replace typs (Utf8.mk "xsd:anyType") (ref AnyType)
(* Main parsing function *)
let schema_of_node root =
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 root);
(_namespaces rt)
in
register_ns root;
let qualify,targetNamespace =
match _may_attr "targetNamespace" root with
......@@ -199,9 +204,18 @@ let schema_of_node root =
validation_error ("Can't resolve: " ^ Utf8.get_str s))
in
let find_global_component tag_pred name =
let roots = ref [ ] in
let find_global_component tag_pred name err =
let basename = Utf8.get_str (snd (Ns.split_qname name)) in
_find (fun n -> (_has_tag n tag_pred) && (_is_attr "name" n basename)) root
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)
in
aux !roots
in
let rec resolve_typ name =
......@@ -221,11 +235,7 @@ let schema_of_node root =
let name = fix_namespace name in
try Hashtbl.find attrs name
with Not_found ->
let node =
try find_global_component ((=) "xsd:attribute") name
with Not_found ->
validation_error ("Can't find declaration of attribute: " ^
Utf8.get_str name)
let node = find_global_component ((=) "xsd:attribute") name "attribute"
in
let att_decl = parse_att_decl node in
Hashtbl.replace attrs name att_decl;
......@@ -236,10 +246,7 @@ let schema_of_node root =
try Hashtbl.find attr_groups name
with Not_found ->
let node =
try find_global_component ((=) "xsd:attributeGroup") name
with Not_found ->
validation_error
("Can't find definition of attribute group: " ^ Utf8.get_str name)
find_global_component ((=) "xsd:attributeGroup") name "attribute group"
in
let att_group_decl = parse_att_group node in
Hashtbl.replace attr_groups name att_group_decl;
......@@ -249,12 +256,7 @@ let schema_of_node root =
let name = fix_namespace name in
try Hashtbl.find model_groups name
with Not_found ->
let node =
try find_global_component ((=) "xsd:group") name
with Not_found ->
validation_error
("Can't find definition of model group: " ^ Utf8.get_str name)
in
let node = find_global_component ((=) "xsd:group") name "model group" in
let model_group = parse_model_group_def node in
Hashtbl.replace model_groups name model_group;
model_group
......@@ -554,47 +556,54 @@ let schema_of_node root =
in
(* First pass: allocate slots for global elements and types *)
let register n = function
(* First pass: allocate slots for global elements and types,
perform inclusion *)
let todo = ref [] in
let rec register n = function
| "xsd:element" ->
let name = qualify (_attr "name" n) in
if (Hashtbl.mem elts name) then
validation_error ("Redefinition of element " ^ Utf8.get_str name);
Hashtbl.add elts name (ref fake_elt_decl)
| "xsd:simpleType" | "xsd:complexType" ->
let r = ref fake_elt_decl in
Hashtbl.add elts name r;
todo := (fun () -> r := parse_elt_decl n) :: !todo
| ("xsd:simpleType" | "xsd:complexType") as s ->
let name = qualify (_attr "name" n) in
if (Hashtbl.mem typs name) then
validation_error ("Redefinition of type " ^ Utf8.get_str name);
Hashtbl.add typs name (ref fake_type_def)
| _ -> () in
_iter_elems root register;
(* Second pass: compute the definitions *)
let toplevel n = function
| "xsd:element" ->
let name = qualify (_attr "name" n) in
(try (Hashtbl.find elts name) := parse_elt_decl n
with Not_found -> assert false)
| "xsd:simpleType" ->
let name = qualify (_attr "name" n) in
(try (Hashtbl.find typs name) := !(parse_simple_type n)
with Not_found -> assert false)
| "xsd:complexType" ->
let name = qualify (_attr "name" n) in
(try (Hashtbl.find typs name) := !(parse_complex_type n)
with Not_found -> assert false)
let r = ref fake_type_def in
Hashtbl.add typs name r;
let f = if s="xsd:simpleType" then parse_simple_type
else parse_complex_type in
todo := (fun () -> r := !(f n)) :: !todo
| "xsd:attribute" ->
let name = qualify (_attr "name" n) in
Hashtbl.add attrs name (parse_att_decl n)
todo := (fun () -> Hashtbl.add attrs name (parse_att_decl n)):: !todo;
| "xsd:attributeGroup" ->
let name = qualify (_attr "name" n) in
Hashtbl.add attr_groups name (parse_att_group n)
todo := (fun () -> Hashtbl.add attr_groups name (parse_att_group n))::
!todo
| "xsd:group" ->
let name = qualify (_attr "name" n) in
Hashtbl.add model_groups name (parse_model_group_def n)
todo :=
(fun () -> Hashtbl.add model_groups name (parse_model_group_def n))::
!todo
| "xsd:include" ->
let local = _attr "schemaLocation" n in
let new_uri = Url.local uri (Utf8.get_str local) in
print_endline ("Fetching " ^ new_uri); flush stdout;
let root = node_of_uri new_uri in
register_ns root;
register_root root
| _ -> ()
and register_root rt =
roots := rt :: !roots;
_iter_elems rt register
in
_iter_elems root toplevel;
register_root root;
(* Second pass: compute the definitions *)
List.iter (fun f -> f ()) !todo;
{
targetNamespace = targetNamespace;
types = hashtbl_deref typs;
......@@ -605,6 +614,3 @@ let schema_of_node root =
}
let schema_of_file s = schema_of_node (node_of_file s)
let schema_of_string s = schema_of_node (node_of_string s)
schema/schema_parser.mli
View file @ 6481d59a
......@@ -2,5 +2,4 @@
open Schema_types
val schema_of_file: string -> schema
val schema_of_string: string -> schema
val schema_of_uri: string -> schema
schema/schema_xml.ml
View file @ 6481d59a
......@@ -41,17 +41,15 @@ let new_xsd_config () =
let node_of src =
Pxp_tree_parser.parse_wfcontent_entity (new_xsd_config ()) src spec
let wrap_err f x =
try f x
let node_of_uri uri =
try
let source = match Url.process uri with
| Url.Filename s -> Pxp_types.from_file s
| Url.Url s -> Pxp_types.from_string s
in
node_of source
with exn -> raise (Location.Generic (Pxp_types.string_of_exn exn))
let node_of_file =
wrap_err (fun fname -> node_of (Pxp_types.from_file fname))
let node_of_string =
wrap_err (fun s -> node_of (Pxp_types.from_string s))
let _may_attr name n =
try
match n#attribute name with
......
schema/schema_xml.mli
View file @ 6481d59a
......@@ -3,8 +3,7 @@ open Encodings
module Node: Set.OrderedType
type node = Node.t
val node_of_file: string -> node
val node_of_string: string -> node
val node_of_uri: string -> node
val _may_attr: string -> node -> Utf8.t option
val _is_attr: string -> node -> string -> bool
......
typing/typer.ml
View file @ 6481d59a
......@@ -1772,10 +1772,7 @@ open Schema_types
let get_schema uri =
try Hashtbl.find !schemas uri
with Not_found ->
let schema = match Url.process uri with
| Url.Filename s -> Schema_parser.schema_of_file s
| Url.Url s -> Schema_parser.schema_of_string s in
let schema = Schema_parser.schema_of_uri uri in
let log_schema_component kind uri name cd_type =
(* if not (Schema_builtin.is_builtin name) then begin
Format.fprintf Format.std_formatter
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment