strange bug-fix to allow compilation on recent ocaml+camlp5o

[helm.git] / helm / software / components / metadata / metadataDeps.ml

diff --git a/helm/software/components/metadata/metadataDeps.ml b/helm/software/components/metadata/metadataDeps.ml
index 91fa8004ca14ae49694c98209a751ffb765d2f2b..e6fcab592577812706ded37f667b5a21a220a7c2 100644 (file)
--- a/helm/software/components/metadata/metadataDeps.ml
+++ b/helm/software/components/metadata/metadataDeps.ml
@@ -64,14 +64,17 @@ let direct_deps ~dbd uri =
           prerr_endline "invalid (direct) refObj metadata row";
           assert false 
   in
-  let do_query tbl =
-    let res = HMysql.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 =
-      HMysql.map res (fun row -> unbox_row (obj_metadata_of_row row)) in
+      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 =
@@ -82,14 +85,62 @@ let inverse_deps ~dbd uri =
           prerr_endline "invalid (inverse) refObj metadata row";
           assert false 
   in
-  let do_query tbl =
-    let res = HMysql.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 =
-      HMysql.map res (fun row -> unbox_row (inv_obj_metadata_of_row row)) in
+      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 =
+  struct
+   type t = UriManager.uri
+   let compare = UriManager.compare
+  end in
+ let module Topo = HTopoSort.Make(OrderedUri) in
+  Topo.topological_sort uris
+   (fun uri -> fst (List.split (direct_deps ~dbd uri)))
+
+let sorted_uris_of_baseuri ~dbd baseuri =
+   let sql_pat = 
+     Pcre.replace ~pat:"([^\\\\])_" ~templ:"$1\\_" baseuri ^ "%"
+   in
+   let query dbtype tbl =
+      Printf.sprintf
+         ("SELECT source FROM %s WHERE source LIKE \"%s\" "
+          ^^ HSql.escape_string_for_like dbtype dbd)
+         tbl sql_pat
+   in
+   let map cols = match cols.(0) with
+      | Some s -> UriManager.uri_of_string s
+      | _ -> assert false
+   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 =
+         Pcre.replace ~rex:(Pcre.regexp "#xpointer\\(1/1\\)") ~templ:""
+                      (UriManager.string_of_uri uri)
+      in
+      try ignore (Pcre.exec ~rex:(Pcre.regexp"#xpointer") s); None
+      with Not_found -> Some (UriManager.uri_of_string s)
+   in
+   HExtlib.filter_map filter_map sorted_uris
 
 module DepGraph =
 struct
@@ -118,7 +169,7 @@ struct
     neighborhood UriTbl.t * UriManager.uri
       * (UriManager.uri -> UriManager.uri list) * bool
 
-  let dummy =
+  let dummy : t =
     UriTbl.create 0, UriManager.uri_of_string "cic:/a.con",
       (fun _ -> []), false
 
@@ -132,12 +183,13 @@ struct
         (*eprintf "Node '%s' not found.\n" (UriManager.string_of_uri uri);*)
         assert false
     in
-    Pp.header ~graph_attrs:["rankdir", "LR"] ~node_attrs:global_node_attrs fmt;
+    Pp.header ~graph_type:"strict digraph" ~graph_attrs:["rankdir", "LR"] ~node_attrs:global_node_attrs fmt;
     let rec aux =
       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
@@ -153,8 +205,8 @@ struct
                 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;