prerr_endline "invalid (direct) refObj metadata row";
assert false
in
- let do_query tbl =
- let res = HSql.exec dbd (SqlStatements.direct_deps tbl uri) in
+ let do_query (dbtype, tbl) =
+ let res =
+ HSql.exec dbtype dbd (SqlStatements.direct_deps tbl uri dbtype dbd)
+ in
let deps =
HSql.map res (fun row -> unbox_row (obj_metadata_of_row row)) in
deps
in
- do_query (MetadataTypes.obj_tbl ())
- @ do_query MetadataTypes.library_obj_tbl
+ do_query (HSql.User, MetadataTypes.obj_tbl ())
+ @ do_query (HSql.Library, MetadataTypes.library_obj_tbl)
+ @ do_query (HSql.Legacy, MetadataTypes.library_obj_tbl)
let inverse_deps ~dbd uri =
let inv_obj_metadata_of_row =
prerr_endline "invalid (inverse) refObj metadata row";
assert false
in
- let do_query tbl =
- let res = HSql.exec dbd (SqlStatements.inverse_deps tbl uri) in
+ let do_query (dbtype, tbl) =
+ let res =
+ HSql.exec dbtype dbd (SqlStatements.inverse_deps tbl uri dbtype dbd)
+ in
let deps =
HSql.map res (fun row -> unbox_row (inv_obj_metadata_of_row row)) in
deps
in
- do_query (MetadataTypes.obj_tbl ())
- @ do_query MetadataTypes.library_obj_tbl
+ do_query (HSql.User, MetadataTypes.obj_tbl ())
+ @ do_query (HSql.Library, MetadataTypes.library_obj_tbl)
+ @ do_query (HSql.Legacy, MetadataTypes.library_obj_tbl)
let topological_sort ~dbd uris =
let module OrderedUri =
let sql_pat =
Pcre.replace ~pat:"([^\\\\])_" ~templ:"$1\\_" baseuri ^ "%"
in
- let query =
+ let query dbtype tbl =
Printf.sprintf
("SELECT source FROM %s WHERE source LIKE \"%s\" "
- ^^ HSql.escape_string_for_like ^^ " UNION " ^^
- "SELECT source FROM %s WHERE source LIKE \"%s\" "
- ^^ HSql.escape_string_for_like)
- (MetadataTypes.name_tbl ()) sql_pat
- MetadataTypes.library_name_tbl sql_pat
+ ^^ HSql.escape_string_for_like dbtype dbd)
+ tbl sql_pat
in
- let result = HSql.exec dbd query in
let map cols = match cols.(0) with
| Some s -> UriManager.uri_of_string s
| _ -> assert false
in
- let uris = HSql.map result map in
+ let uris =
+ List.fold_left
+ (fun acc (dbtype, table) ->
+ let result = HSql.exec dbtype dbd (query dbtype table) in
+ HSql.map result map @ acc)
+ []
+ [HSql.User, MetadataTypes.name_tbl ();
+ HSql.Library, MetadataTypes.library_name_tbl;
+ HSql.Legacy, MetadataTypes.library_name_tbl]
+ in
let sorted_uris = topological_sort ~dbd uris in
let filter_map uri =
let s =
function
| [] -> ()
| uri :: tl ->
- let suri = UriManager.string_of_uri uri in
+ let nice = UriManager.strip_xpointer in
+ let suri = UriManager.string_of_uri (nice uri) in
Pp.node suri
~attrs:([ "href", UriManager.string_of_uri uri;
"label", label_of_uri uri
let neighbs = UriTbl.find adjlist uri in
if Lazy.lazy_is_val neighbs.adjacency then begin
let adjacency, _ =
- HExtlib.split_nth neighbs.shown (Lazy.force neighbs.adjacency)
+ HExtlib.split_nth "MD 1" neighbs.shown (Lazy.force neighbs.adjacency)
in
List.iter
(fun dest ->
let uri1, uri2 = if invert then dest, uri else uri, dest in
- Pp.edge (UriManager.string_of_uri uri1)
- (UriManager.string_of_uri uri2) fmt)
+ Pp.edge (UriManager.string_of_uri (nice uri1))
+ (UriManager.string_of_uri (nice uri2)) fmt)
adjacency;
new_nodes := adjacency
end;
UriTbl.add adjlist dest neighborhood)
adjacency;
neighbs.shown <- weight;
- fst (HExtlib.split_nth weight adjacency), weight
+ fst (HExtlib.split_nth "MD 2" weight adjacency), weight
else begin (* nodes has been expanded at least once *)
let adjacency = Lazy.force neighbs.adjacency in
let total_nodes = List.length adjacency in
let shown_before = neighbs.shown in
neighbs.shown <- min (neighbs.shown + fat_increment) total_nodes;
let new_shown = neighbs.shown - shown_before in
- (fst (HExtlib.split_nth new_shown (List.rev adjacency))), new_shown
+ (fst (HExtlib.split_nth "MD 3" new_shown (List.rev adjacency))), new_shown
end else
[], 0 (* all children are already shown *)
end