checked in new version of matita from svn

[helm.git] / helm / matita / matitaDb.ml

diff --git a/helm/matita/matitaDb.ml b/helm/matita/matitaDb.ml
index a6eb73ded475b87fac61ae4fae99806301b11467..93a1abaa5a731d34c81f044fbb8cc76787d0b3fc 100644 (file)
--- a/helm/matita/matitaDb.ml
+++ b/helm/matita/matitaDb.ml
@@ -1,4 +1,4 @@
-(* Copyright (C) 2004, HELM Team.
+(* Copyright (C) 2004-2005, HELM Team.
  * 
  * This file is part of HELM, an Hypertextual, Electronic
  * Library of Mathematics, developed at the Computer Science
@@ -25,13 +25,28 @@
 
 open Printf ;;
 
-let clean_owner_environment dbd owner = 
+let instance =
+  let dbd = lazy (
+    Mysql.quick_connect
+      ~host:(Helm_registry.get "db.host")
+      ~user:(Helm_registry.get "db.user")
+      ~database:(Helm_registry.get "db.database")
+      ())
+  in
+  fun () -> Lazy.force dbd
+
+
+let xpointer_RE = Pcre.regexp "#.*$"
+
+let clean_owner_environment () =
+  let dbd = instance () in
+  let owner = (Helm_registry.get "matita.owner") in
   let obj_tbl = MetadataTypes.obj_tbl () in
   let sort_tbl = MetadataTypes.sort_tbl () in
   let rel_tbl = MetadataTypes.rel_tbl () in
   let name_tbl =  MetadataTypes.name_tbl () in
   let conclno_tbl = MetadataTypes.conclno_tbl () in
-  let conclno_hyp_tbl = MetadataTypes.conclno_hyp_tbl () in
+  let conclno_hyp_tbl = MetadataTypes.fullno_tbl () in
   let statements = [
     sprintf "DROP TABLE %s ;" obj_tbl;
     sprintf "DROP TABLE %s ;" sort_tbl;
@@ -50,34 +65,40 @@ DROP INDEX no_inconcl_aux_no ON no_inconcl_aux (no);
 DROP INDEX no_concl_hyp_source ON no_concl_hyp (source);
 DROP INDEX no_concl_hyp_no ON no_concl_hyp (no);
 *)
-  (try
-    MetadataDb.clean ~dbd 
-  with
-      exn -> 
-         match Mysql.errno dbd with 
-         | Mysql.No_such_table -> () 
-         | _ -> raise exn
-         | _ -> ()
-  );
+  let owned_uris =
+    try
+      MetadataDb.clean ~dbd
+    with Mysql.Error _ as exn ->
+      match Mysql.errno dbd with 
+      | Mysql.No_such_table -> []
+      | _ -> raise exn
+  in
+  List.iter
+    (fun uri ->
+      let uri = Pcre.replace ~rex:xpointer_RE ~templ:"" uri in
+      List.iter
+        (fun suffix -> Http_getter.unregister (uri ^ suffix))
+        [""; ".body"; ".types"])
+    owned_uris;
   List.iter (fun statement -> 
     try
       ignore (Mysql.exec dbd statement)
-    with
-      exn -> 
-         match Mysql.errno dbd with 
-         | Mysql.No_such_table -> ()
-         | _ -> raise exn
-         | _ -> ()
-      ) statements
+    with Mysql.Error _ as exn ->
+      match Mysql.errno dbd with 
+      | Mysql.Bad_table_error -> () 
+      | _ -> raise exn
+    ) statements;
 ;;
 
-let create_owner_environment dbd owner = 
+let create_owner_environment () = 
+  let dbd = instance () in
+  let owner = (Helm_registry.get "matita.owner") in
   let obj_tbl = MetadataTypes.obj_tbl () in
   let sort_tbl = MetadataTypes.sort_tbl () in
   let rel_tbl = MetadataTypes.rel_tbl () in
   let name_tbl =  MetadataTypes.name_tbl () in
   let conclno_tbl = MetadataTypes.conclno_tbl () in
-  let conclno_hyp_tbl = MetadataTypes.conclno_hyp_tbl () in
+  let conclno_hyp_tbl = MetadataTypes.fullno_tbl () in
   let statements = [
     sprintf "CREATE TABLE %s (
                   source varchar(255) binary not null,
@@ -132,3 +153,46 @@ CREATE INDEX no_concl_hyp_no ON no_concl_hyp (no);
       ) statements
 ;;
 
+(* removes uri from the ownerized tables, and returns the list of other objects
+ * (theyr uris) that ref the one removed. 
+ * AFAIK there is no need to return it, since the MatitaTypes.staus should
+ * contain all defined objects. but to double ckeck we do not garbage the
+ * metadata...
+ *)
+let remove_uri uri =
+  let obj_tbl = MetadataTypes.obj_tbl () in
+  let sort_tbl = MetadataTypes.sort_tbl () in
+  let rel_tbl = MetadataTypes.rel_tbl () in
+  let name_tbl =  MetadataTypes.name_tbl () in
+  let conclno_tbl = MetadataTypes.conclno_tbl () in
+  let conclno_hyp_tbl = MetadataTypes.fullno_tbl () in
+  let dbd = instance () in
+  let suri = UriManager.string_of_uri uri in 
+  let query table suri = sprintf 
+    "DELETE FROM %s WHERE source LIKE '%s%%'" table (Mysql.escape suri)
+  in
+  List.iter (fun t -> 
+    try 
+      ignore (Mysql.exec dbd (query t suri))
+    with
+      exn -> raise exn (* no errors should be accepted *)
+    ) [obj_tbl;sort_tbl;rel_tbl;name_tbl;conclno_tbl;conclno_hyp_tbl];
+  (* and now the debug job *)  
+  let dbg_q = 
+    sprintf "SELECT source FROM %s WHERE h_occurrence LIKE '%s%%'" obj_tbl suri
+  in
+  try 
+    let rc = Mysql.exec dbd dbg_q in
+    let l = ref [] in
+    Mysql.iter rc (fun a -> match a.(0) with None ->()|Some a -> l := a:: !l);
+    let l = List.sort Pervasives.compare !l in
+    let rec uniq = function 
+      | [] -> []
+      | h::[] -> [h]
+      | h1::h2::tl when h1 = h2 -> uniq (h2 :: tl) 
+      | h1::tl (* when h1 <> h2 *) -> h1 :: uniq tl
+    in
+    uniq l
+  with
+    exn -> raise exn (* no errors should be accepted *)
+