open Dbf_sql
exception Invalid_db_file
let checked_dtd = Dtd.check (Dtd.parse_file Dbf_installation.db_dtd_file)
let pcdata_tag = fun ~name ~pcdata ->
Xml.Element (name, [], [Xml.PCData pcdata])
let xml_of_type = fun ty spec_ty ->
let children = ref [] in
let new_info = fun tag -> children := tag :: !children in
new_info (pcdata_tag "name" (SQL_ty.string_of_type ty));
(match SQL_ty.get_display_size ty with
| Some i -> new_info (pcdata_tag "dispsize" (string_of_int i))
| None -> ());
(match SQL_ty.get_precision ty with
| Some i -> new_info (pcdata_tag "precision" (string_of_int i))
| None -> ());
(match SQL_ty.string_of_type_options ty with
| Some opt -> new_info (pcdata_tag "options" opt)
| None -> ());
Dbf_misc.StringMap.iter
(fun db ty ->
new_info (Xml.Element ("spec_ty", ["db", db], [Xml.PCData ty])))
spec_ty;
let children = List.rev !children in
Xml.Element ("type", [], children)
let xml_of_tableref = fun table ->
pcdata_tag "tableref" table.SQL_db.ta_name
let xml_of_columnref = fun column ->
pcdata_tag "columnref" column.SQL_db.col_name
let xml_of_columnfullref = fun column ->
Xml.Element ("columnfullref", [],
[xml_of_tableref column.SQL_db.col_table;
xml_of_columnref column])
let xml_of_column = fun column ->
let spec_options = fun db options ->
let children = ref [] in
let new_info = fun tag -> children := tag :: !children in
List.iter
(fun option -> new_info (pcdata_tag "spec_option" option))
options;
Xml.Element ("spec_options", [("db", db)], List.rev !children)
in
let children = ref [] in
let new_info = fun tag -> children := tag :: !children in
new_info (pcdata_tag "name" column.SQL_db.col_name);
new_info (pcdata_tag "comment" column.SQL_db.col_comment);
new_info (xml_of_type column.SQL_db.col_type column.SQL_db.col_spec_ty);
new_info (pcdata_tag "ocaml_type" column.SQL_db.col_ocaml_ty);
new_info (pcdata_tag "sql2ml" column.SQL_db.col_sql2ml);
new_info (pcdata_tag "ml2sql" column.SQL_db.col_ml2sql);
Dbf_misc.StringMap.iter
(fun db options -> new_info (spec_options db options))
column.SQL_db.col_spec_options;
let children = List.rev !children
and attrs = ["nullable", (string_of_bool column.SQL_db.col_nullable)]
in
Xml.Element ("column", attrs, children)
let xml_of_table = fun table ->
let children = ref [] in
let new_info = fun tag -> children := tag :: !children
and columns = List.map xml_of_column table.SQL_db.ta_columns in
new_info (pcdata_tag "name" table.SQL_db.ta_name);
new_info (pcdata_tag "comment" table.SQL_db.ta_comment);
new_info (Xml.Element ("columns", [], columns));
if table.SQL_db.ta_pkey <> [] then begin
let columnsref =
let children = ref [] in
let new_info = fun tag -> children := tag :: !children in
List.iter
(fun c -> new_info (xml_of_columnref c)) table.SQL_db.ta_pkey;
!children
in
new_info (Xml.Element ("pkey", [], columnsref))
end;
let children = List.rev !children
and attrs = ["logged", (string_of_bool table.SQL_db.ta_logged)]
in
Xml.Element ("table", attrs, children)
let xml_of_join = fun (table, cs) ->
let children = ref [] in
let new_infos = fun tag -> children := tag :: !children in
new_infos (xml_of_tableref table);
List.iter
(fun (c1, c2) ->
assert (c2.SQL_db.col_table == table);
new_infos
(Xml.Element
("columneq", [],
[xml_of_columnfullref c1; xml_of_columnref c2])))
cs;
let children = List.rev !children in
Xml.Element ("join", [], children)
let xml_of_vtable = fun vtable ->
let children = ref [] in
let new_info = fun tag -> children := tag :: !children in
new_info (pcdata_tag "name" vtable.SQL_db.vt_name);
new_info (xml_of_tableref vtable.SQL_db.vt_ftable);
List.iter
(fun join -> new_info (xml_of_join join))
vtable.SQL_db.vt_join;
let children = List.rev !children in
Xml.Element ("vtable", [], children)
let xml_of_index = fun index ->
let table =
match index.SQL_db.idx_columns with
| [] -> Dbf_misc.ie ()
| hd :: _ -> hd.SQL_db.col_table
in
let children = ref [] in
let new_info = fun tag -> children := tag :: !children in
new_info (pcdata_tag "name" index.SQL_db.idx_name);
new_info (pcdata_tag "tableref" table.SQL_db.ta_name);
List.iter
(fun c -> new_info (pcdata_tag "columnref" c.SQL_db.col_name))
index.SQL_db.idx_columns;
let children = List.rev !children in
Xml.Element ("index",
["unique", string_of_bool index.SQL_db.idx_unique],
children)
let xml_of_query = fun query ->
let children = ref [] in
let new_info = fun tag -> children := tag :: !children in
new_info (pcdata_tag "name" query.SQL_db.qry_name);
new_info (pcdata_tag "querytext" query.SQL_db.qry_query);
new_info (pcdata_tag "comment" query.SQL_db.qry_comment);
let children = List.rev !children in
Xml.Element ("query", [], children)
let xml_of_db = fun db ->
let tables = List.map xml_of_table db.SQL_db.db_tables
and vtables = List.map xml_of_vtable db.SQL_db.db_vtables
and indexes = List.map xml_of_index db.SQL_db.db_indexes
and queries = List.map xml_of_query db.SQL_db.db_queries in
let xml_tables = Xml.Element ("tables", [], tables)
and xml_vtables = Xml.Element ("vtables", [], vtables)
and xml_indexes = Xml.Element ("indexes", [], indexes)
and xml_queries = Xml.Element ("queries", [], queries) in
Xml.Element ("db", [], [xml_tables; xml_vtables; xml_indexes; xml_queries])
let db_int_of_string = fun s ->
try int_of_string s
with Failure "int_of_string" -> raise Invalid_db_file
let db_bool_of_string = fun s ->
try bool_of_string s
with Failure "bool_of_string" -> raise Invalid_db_file
let pcdata_from_tag = fun tag ->
match tag with
| Xml.Element (_, _, [Xml.PCData text]) -> text
| _ -> Dbf_misc.ie ()
let pcdata_from_child_tag_opt =
let check_for_tag = fun name tag ->
match tag with
| Xml.Element (name', _, children)
when name = name' -> begin
match children with
| [Xml.PCData _] -> true
| _ -> Dbf_misc.ie ()
end
| _ -> false
in
fun tag name ->
try
match tag with
| Xml.Element (_, _, children) ->
let c = List.find (check_for_tag name) children in
Some (pcdata_from_tag c)
| _ -> Dbf_misc.ie ()
with
| Not_found -> None
let pcdata_from_child_tag = fun tag name ->
match pcdata_from_child_tag_opt tag name with
| Some t -> t
| None -> Dbf_misc.ie ()
let find_first_tag_opt = fun tag name ->
match tag with
| Xml.Element (_, _, children) -> begin
let eq_fct = function
| (Xml.Element (name', _, _)) when name = name'
-> true
| _ -> false
in
try
Some (List.find eq_fct children)
with
| Not_found -> None
end
| _ ->
Dbf_misc.ie ()
let find_first_tag = fun tag name ->
match find_first_tag_opt tag name with
| None -> Dbf_misc.ie ()
| Some v -> v
let find_all_tags = fun tag name ->
let rec find_all = function
| ((Xml.Element (name', _, _)) as t) :: tl when name = name' ->
t :: (find_all tl)
| _ :: tl -> find_all tl
| [] -> []
in
match tag with
| Xml.Element (_, _, children) -> find_all children
| _ -> Dbf_misc.ie ()
let ty_of_dtd_valid_xml = fun xml ->
let dispsize = pcdata_from_child_tag_opt xml "dispsize"
and precision = pcdata_from_child_tag_opt xml "precision"
and options = pcdata_from_child_tag_opt xml "options"
and name = pcdata_from_child_tag xml "name"
and spec_tys = find_all_tags xml "spec_ty"
in
try
let ty =
SQL_ty.type_of_string
?dispsize:(Dbf_misc.apply_opt db_int_of_string dispsize)
?precision:(Dbf_misc.apply_opt db_int_of_string precision)
?options:options
name
and spec_tys =
List.fold_left
(fun acc xml ->
let db = Xml.attrib xml "db"
and ty = pcdata_from_tag xml in
Dbf_misc.StringMap.add db ty acc)
Dbf_misc.StringMap.empty spec_tys
in
(ty, spec_tys)
with
| SQL_ty.Invalid_type _ -> raise Invalid_db_file
let column_of_dtd_valid_xml = fun table xml ->
let fetch_spec_options = fun () ->
let tags = find_all_tags xml "spec_options"
and result = ref Dbf_misc.StringMap.empty in
let fetch_spec_options_for_db = fun xml ->
let db = Xml.attrib xml "db" in
let fetch_option = function
| Xml.Element ("spec_option", [], [Xml.PCData option]) ->
option
| _ ->
Dbf_misc.ie ();
in
result := Dbf_misc.StringMap.add
db (List.map fetch_option (Xml.children xml))
!result
in
List.iter fetch_spec_options_for_db tags;
!result
in
let name = pcdata_from_child_tag xml "name"
and comment = pcdata_from_child_tag xml "comment"
and (ty, spec_tys) = ty_of_dtd_valid_xml (find_first_tag xml "type")
and ocamlty = pcdata_from_child_tag xml "ocaml_type"
and sql2ml = pcdata_from_child_tag xml "sql2ml"
and ml2sql = pcdata_from_child_tag xml "ml2sql"
and options = fetch_spec_options ()
in
try
let column =
SQL_db.insert_column table
~name:name
~comment:comment
~ty:ty
~nullable:(db_bool_of_string (Xml.attrib xml "nullable"))
()
in
column.SQL_db.col_spec_options <- options;
column.SQL_db.col_spec_ty <- spec_tys;
column.SQL_db.col_ocaml_ty <- ocamlty;
column.SQL_db.col_sql2ml <- sql2ml;
column.SQL_db.col_ml2sql <- ml2sql;
column
with
| SQL_db.Invalid_name _ -> raise Invalid_db_file
| SQL_db.Duplicated_name _ -> raise Invalid_db_file
let table_of_dtd_valid_xml = fun db xml ->
let name = pcdata_from_child_tag xml "name"
and comment = pcdata_from_child_tag xml "comment"
and logged = db_bool_of_string (Xml.attrib xml "logged")
and columns = find_first_tag xml "columns"
and pkey = find_first_tag_opt xml "pkey"
in
try
let table = SQL_db.insert_table db
~name:name ~comment:comment ~logged
in
List.iter
(fun c -> ignore (column_of_dtd_valid_xml table c))
(Xml.children columns);
begin
match pkey with
| None -> ()
| Some pkey ->
let rec fetch = function
| [] ->
[]
| Xml.Element (_, [], [Xml.PCData (c)]) :: tl ->
(SQL_db.column_by_name table c) :: (fetch tl)
| _ ->
Dbf_misc.ie ()
in
SQL_db.set_primary_key table (fetch (Xml.children pkey))
end;
table
with
| SQL_db.Invalid_name _ -> raise Invalid_db_file
| SQL_db.Duplicated_name _ -> raise Invalid_db_file
| Not_found -> raise Invalid_db_file
let index_of_dtd_valid_xml = fun db xml ->
let name = pcdata_from_child_tag xml "name"
and tableref = pcdata_from_child_tag xml "tableref"
and columnsref = find_all_tags xml "columnref" in
try
let table = SQL_db.table_by_name db tableref in
let columns =
List.map
(fun c -> SQL_db.column_by_name table ~name:(pcdata_from_tag c))
columnsref
and unique =
db_bool_of_string (Xml.attrib xml "unique")
in
SQL_db.insert_index ~name:name ~columns:columns
~unique:unique
with
| Not_found -> raise Invalid_db_file
| SQL_db.Invalid_name _ -> raise Invalid_db_file
| SQL_db.Invalid_args _ -> raise Invalid_db_file
| SQL_db.Duplicated_name _ -> raise Invalid_db_file
let query_of_dtd_valid_xml = fun db xml ->
let name = pcdata_from_child_tag xml "name"
and query = pcdata_from_child_tag xml "querytext"
and comment = pcdata_from_child_tag xml "comment" in
try
SQL_db.insert_query db ~name ~query ~comment
with
| Not_found -> raise Invalid_db_file
| SQL_db.Invalid_name _ -> raise Invalid_db_file
| SQL_db.Invalid_args _ -> raise Invalid_db_file
| SQL_db.Duplicated_name _ -> raise Invalid_db_file
let column_fullref_of_dtd_valid_xml = fun db xml ->
let tableref = pcdata_from_child_tag xml "tableref"
and columnref = pcdata_from_child_tag xml "columnref" in
try
let table = SQL_db.table_by_name db tableref in
SQL_db.column_by_name table columnref
with
| Not_found -> raise Invalid_db_file
let columneq_of_dtd_valid_xml = fun table xml ->
let columnfullref = find_first_tag xml "columnfullref"
and columnref = pcdata_from_child_tag xml "columnref" in
try
let c1 = column_fullref_of_dtd_valid_xml
table.SQL_db.ta_db columnfullref
and c2 = SQL_db.column_by_name table columnref in
(c1, c2)
with
| Not_found -> raise Invalid_db_file
let join_of_dtd_valid_xml = fun db xml ->
let tableref = pcdata_from_child_tag xml "tableref"
and columnseq = find_all_tags xml "columneq" in
try
let table = SQL_db.table_by_name db tableref in
let ceq =
List.map (columneq_of_dtd_valid_xml table) columnseq
in
(table, ceq)
with
| Not_found -> raise Invalid_db_file
let vtable_of_dtd_valid_xml = fun db xml ->
let name = pcdata_from_child_tag xml "name"
and ftableref = pcdata_from_child_tag xml "tableref"
and joins = find_all_tags xml "join" in
try
let ftable = SQL_db.table_by_name db ftableref in
let vtable = SQL_db.create_vtable name ftable in
List.iter
(fun j -> let (table, ceq) = join_of_dtd_valid_xml db j in
SQL_db.do_join vtable table ceq)
joins;
SQL_db.link_vtable_to_db vtable;
vtable
with
| Not_found -> raise Invalid_db_file
| SQL_db.Invalid_name _ -> raise Invalid_db_file
| SQL_db.Invalid_args _ -> raise Invalid_db_file
| SQL_db.Duplicated_name _ -> raise Invalid_db_file
let db_of_xml = fun xml ->
let xml =
try Dtd.prove checked_dtd "db" xml
with
| Dtd.Check_error _ -> raise Invalid_db_file
| Dtd.Prove_error _ -> raise Invalid_db_file
in
let db = SQL_db.create_empty () in
let tables = find_first_tag xml "tables"
and indexes = find_first_tag xml "indexes"
and queries = find_first_tag xml "queries"
and vtables = find_first_tag xml "vtables" in
try
List.iter
(fun t -> ignore (table_of_dtd_valid_xml db t))
(Xml.children tables);
List.iter
(fun i -> ignore (index_of_dtd_valid_xml db i))
(Xml.children indexes);
List.iter
(fun q -> ignore (query_of_dtd_valid_xml db q))
(Xml.children queries);
List.iter
(fun v -> ignore (vtable_of_dtd_valid_xml db v))
(Xml.children vtables);
db
with
| Xml.Not_pcdata _ -> Dbf_misc.ie ()
| Xml.Not_element _ -> Dbf_misc.ie ()
| Xml.No_attribute _ -> Dbf_misc.ie ()
let db_of_file = fun filename ->
let xml =
try
Xml.parse_file filename
with
| Xml.Error _ -> raise Invalid_db_file
| Xml.File_not_found _ -> raise Invalid_db_file
in
db_of_xml xml