From 405c47d27dd91cb2a560c8041986da6d3275ca8a Mon Sep 17 00:00:00 2001
From: Claudio Sacerdoti Coen <claudio.sacerdoticoen@unibo.it>
Date: Wed, 23 May 2007 16:19:35 +0000
Subject: [PATCH] Yet another patch to LibraryClean. Now we look for URIs to
 remove both in the filesystem and in the objectName table of the DB.

---
 components/grafite_engine/grafiteEngine.ml |  5 +--
 components/library/libraryClean.ml         | 40 ++++++++++++++++++++++
 components/library/libraryClean.mli        |  1 +
 3 files changed, 44 insertions(+), 2 deletions(-)

diff --git a/components/grafite_engine/grafiteEngine.ml b/components/grafite_engine/grafiteEngine.ml
index c961c58ae..2d478673f 100644
--- a/components/grafite_engine/grafiteEngine.ml
+++ b/components/grafite_engine/grafiteEngine.ml
@@ -725,8 +725,9 @@ let rec eval_command = {ec_go = fun ~disambiguate_command opts status
           HLog.error (Printf.sprintf "uri %s belongs to a read-only repository" value);
           raise (ReadOnlyUri value)
         end;
-        if not (Http_getter_storage.is_empty value) && 
-           opts.clean_baseuri 
+        if (not (Http_getter_storage.is_empty value) ||
+            LibraryClean.db_uris_of_baseuri value <> [])
+           && opts.clean_baseuri 
           then begin
           HLog.message ("baseuri " ^ value ^ " is not empty");
           HLog.message ("cleaning baseuri " ^ value);
diff --git a/components/library/libraryClean.ml b/components/library/libraryClean.ml
index f61fc89c2..54aa860c9 100644
--- a/components/library/libraryClean.ml
+++ b/components/library/libraryClean.ml
@@ -84,6 +84,38 @@ let safe_buri_of_suri suri =
   with
     UM.IllFormedUri _ -> suri
 
+let db_uris_of_baseuri buri =
+ let query = 
+  let buri = buri ^ "/" in 
+  let buri = HSql.escape buri in
+  let obj_tbl = MetadataTypes.name_tbl () in
+  if HSql.isMysql then        
+    sprintf ("SELECT source FROM %s WHERE " 
+    ^^ "source REGEXP '^%s[^/]*$'") obj_tbl buri
+  else
+   begin
+    HLog.debug "Warning SELECT without REGEXP";
+    sprintf
+    ("SELECT source, h_occurrence FROM %s WHERE " ^^ 
+    "h_occurrence LIKE '%s%%'")
+    obj_tbl buri
+   end
+ in
+ try 
+  let rc = HSql.exec (LibraryDb.instance ()) query in
+  let l = ref [] in
+  HSql.iter rc (
+    fun row -> 
+      match row.(0) with 
+      | Some uri when Filename.dirname uri = buri -> 
+          l := uri :: !l
+      | _ -> ());
+  let l = List.sort Pervasives.compare !l in
+  HExtlib.list_uniq l
+ with
+  exn -> raise exn (* no errors should be accepted *)
+;;
+
 let close_uri_list uri_to_remove =
   (* to remove an uri you have to remove the whole script *)
   let buri_to_remove = 
@@ -121,6 +153,14 @@ let close_uri_list uri_to_remove =
       HLog.error ("We were listing an invalid buri: " ^ u);
       exit 1
   in
+  let uri_to_remove_from_db =
+   List.fold_left 
+     (fun acc buri -> db_uris_of_baseuri buri @ acc
+     ) [] buri_to_remove 
+  in
+  let uri_to_remove = uri_to_remove @ uri_to_remove_from_db in
+  let uri_to_remove =
+   HExtlib.list_uniq (List.sort Pervasives.compare uri_to_remove) in
   (* now we want the list of all uri that depend on them *) 
   let depend = 
     List.fold_left
diff --git a/components/library/libraryClean.mli b/components/library/libraryClean.mli
index f4ce6de57..4d65cfe38 100644
--- a/components/library/libraryClean.mli
+++ b/components/library/libraryClean.mli
@@ -23,4 +23,5 @@
  * http://helm.cs.unibo.it/
  *)
 
+val db_uris_of_baseuri : string -> string list
 val clean_baseuris : ?verbose:bool -> string list -> unit
-- 
2.39.2