matita/components/library/libraryClean.ml

   1 (* Copyright (C) 2005, HELM Team.
   2  *
   3  * This file is part of HELM, an Hypertextual, Electronic
   4  * Library of Mathematics, developed at the Computer Science
   5  * Department, University of Bologna, Italy.
   6  *
   7  * HELM is free software; you can redistribute it and/or
   8  * modify it under the terms of the GNU General Public License
   9  * as published by the Free Software Foundation; either version 2
  10  * of the License, or (at your option) any later version.
  11  *
  12  * HELM is distributed in the hope that it will be useful,
  13  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  14  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15  * GNU General Public License for more details.
  16  *
  17  * You should have received a copy of the GNU General Public License
  18  * along with HELM; if not, write to the Free Software
  19  * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  20  * MA  02111-1307, USA.
  21  *
  22  * For details, see the HELM World-Wide-Web page,
  23  * http://helm.cs.unibo.it/
  24  *)
  25
  26 (* $Id$ *)
  27
  28 let debug = false
  29 let debug_prerr = if debug then prerr_endline else ignore
  30
  31 (*module HGT = Http_getter_types;;*)
  32 (*module HG = Http_getter;;*)
  33 (*module UM = UriManager;;*)
  34
  35 let decompile = ref (fun ~baseuri:_ -> assert false);;
  36 let set_decompile_cb f = decompile := f;;
  37
  38 (*
  39 let strip_xpointer s = Pcre.replace ~pat:"#.*$" s ;;
  40
  41 let safe_buri_of_suri suri =
  42   try
  43     UM.buri_of_uri (UM.uri_of_string suri)
  44   with
  45     UM.IllFormedUri _ -> suri
  46
  47 let one_step_depend cache_of_processed_baseuri suri dbtype dbd =
  48   assert false (* MATITA 1.0
  49   let buri = safe_buri_of_suri suri in
  50   if Hashtbl.mem cache_of_processed_baseuri buri then
  51     []
  52   else
  53     begin
  54       Hashtbl.add cache_of_processed_baseuri buri true;
  55       let query =
  56         let buri = buri ^ "/" in
  57         let buri = HSql.escape dbtype dbd buri in
  58         let obj_tbl = MetadataTypes.obj_tbl () in
  59         if HSql.isMysql dbtype dbd then
  60           sprintf ("SELECT source, h_occurrence FROM %s WHERE "
  61             ^^ "h_occurrence REGEXP '"^^
  62             "^%s\\([^/]+\\|[^/]+#xpointer.*\\)$"^^"'")
  63           obj_tbl buri
  64         else
  65           begin
  66             sprintf ("SELECT source, h_occurrence FROM %s WHERE "
  67             ^^ "REGEXP(h_occurrence, '"^^
  68             "^%s\\([^/]+\\|[^/]+#xpointer.*\\)$"^^"')")
  69             obj_tbl buri
  70             (* implementation with vanilla ocaml-sqlite3
  71             HLog.debug "Warning SELECT without REGEXP";
  72             sprintf
  73               ("SELECT source, h_occurrence FROM %s WHERE " ^^
  74                "h_occurrence LIKE '%s%%' " ^^ HSql.escape_string_for_like)
  75                   obj_tbl buri*)
  76           end
  77       in
  78       try
  79         let rc = HSql.exec dbtype dbd query in
  80         let l = ref [] in
  81         HSql.iter rc (
  82           fun row ->
  83             match row.(0), row.(1) with
  84             | Some uri, Some occ when
  85                 Filename.dirname (strip_xpointer occ) = buri ->
  86                   l := uri :: !l
  87             | _ -> ());
  88         let l = List.sort Pervasives.compare !l in
  89         HExtlib.list_uniq l
  90       with
  91         exn -> raise exn (* no errors should be accepted *)
  92     end
  93     *)
  94
  95 let db_uris_of_baseuri buri =
  96   [] (* MATITA 1.0
  97  let dbd = LibraryDb.instance () in
  98  let dbtype =
  99    if Helm_registry.get_bool "matita.system" then HSql.Library else HSql.User
 100  in
 101  let query =
 102   let buri = buri ^ "/" in
 103   let buri = HSql.escape dbtype dbd buri in
 104   let obj_tbl = MetadataTypes.name_tbl () in
 105   if HSql.isMysql dbtype dbd then
 106     sprintf ("SELECT source FROM %s WHERE "
 107     ^^ "source REGEXP '^%s[^/]*(#xpointer.*)?$'") obj_tbl buri
 108   else
 109    begin
 110     sprintf ("SELECT source FROM %s WHERE "
 111       ^^ "REGEXP(source, '^%s[^/]*\\(#xpointer.*\\)?$')") obj_tbl buri
 112    end
 113  in
 114  try
 115   let rc = HSql.exec dbtype dbd query in
 116   let l = ref [] in
 117   HSql.iter rc (
 118     fun row ->
 119       match row.(0) with
 120       | Some uri when Filename.dirname (strip_xpointer uri) = buri ->
 121           l := uri :: !l
 122       | _ -> ());
 123   let l = List.sort Pervasives.compare !l in
 124   HExtlib.list_uniq l
 125  with
 126   exn -> raise exn (* no errors should be accepted *)
 127   *)
 128 ;;
 129
 130 let close_uri_list cache_of_processed_baseuri uri_to_remove =
 131   let dbd = LibraryDb.instance () in
 132   let dbtype =
 133     if Helm_registry.get_bool "matita.system" then HSql.Library else HSql.User
 134   in
 135   (* to remove an uri you have to remove the whole script *)
 136   let buri_to_remove =
 137     HExtlib.list_uniq
 138       (List.fast_sort Pervasives.compare
 139         (List.map safe_buri_of_suri uri_to_remove))
 140   in
 141   (* cleand the already visided baseuris *)
 142   let buri_to_remove =
 143     List.filter
 144       (fun buri ->
 145         if Hashtbl.mem cache_of_processed_baseuri buri then false
 146         else true)
 147       buri_to_remove
 148   in
 149   (* now calculate the list of objects that belong to these baseuris *)
 150   let uri_to_remove =
 151     try
 152       List.fold_left
 153         (fun acc buri ->
 154           let inhabitants = HG.ls ~local:true (buri ^ "/") in
 155           let inhabitants = List.filter
 156               (function HGT.Ls_object _ -> true | _ -> false)
 157             inhabitants
 158           in
 159           let inhabitants = List.map
 160               (function
 161                | HGT.Ls_object e -> buri ^ "/" ^ e.HGT.uri
 162                | _ -> assert false)
 163             inhabitants
 164           in
 165           inhabitants @ acc)
 166       [] buri_to_remove
 167     with HGT.Invalid_URI u ->
 168       HLog.error ("We were listing an invalid buri: " ^ u);
 169       exit 1
 170   in
 171   let uri_to_remove_from_db =
 172    List.fold_left
 173      (fun acc buri ->
 174        let dbu = db_uris_of_baseuri buri in
 175        dbu @ acc
 176      ) [] buri_to_remove
 177   in
 178   let uri_to_remove = uri_to_remove @ uri_to_remove_from_db in
 179   let uri_to_remove =
 180    HExtlib.list_uniq (List.sort Pervasives.compare uri_to_remove) in
 181   (* now we want the list of all uri that depend on them *)
 182   let depend =
 183     List.fold_left
 184     (fun acc u -> one_step_depend cache_of_processed_baseuri u dbtype dbd @ acc)
 185     [] uri_to_remove
 186   in
 187   let depend =
 188     HExtlib.list_uniq (List.fast_sort Pervasives.compare depend)
 189   in
 190   uri_to_remove, depend
 191 ;;
 192
 193 let rec close_db cache_of_processed_baseuri uris next =
 194   match next with
 195   | [] -> uris
 196   | l ->
 197      let uris, next = close_uri_list cache_of_processed_baseuri l in
 198      close_db cache_of_processed_baseuri uris next @ uris
 199 ;;
 200
 201 let cleaned_no = ref 0;;
 202
 203   (** TODO repellent code ... *)
 204 let moo_root_dir = lazy (
 205   let url =
 206     List.assoc "cic:/matita/"
 207       (List.map
 208         (fun pair ->
 209           match
 210             Str.split (Str.regexp "[ \t\r\n]+") (HExtlib.trim_blanks pair)
 211           with
 212           | a::b::_ -> a, b
 213           | _ -> assert false)
 214         (Helm_registry.get_list Helm_registry.string "getter.prefix"))
 215   in
 216   String.sub url 7 (String.length url - 7))
 217 ;;
 218 *)
 219
 220 let close_db _cache_of_processed_baseuri uris _next =
 221   uris (* MATITA 1.0 *)
 222 ;;
 223
 224 let clean_baseuris ?verbose:(_=true) _buris =
 225  (* MATITA 1.0 *) () (*
 226   let cache_of_processed_baseuri = Hashtbl.create 1024 in
 227   let buris = List.map Http_getter_misc.strip_trailing_slash buris in
 228   debug_prerr "clean_baseuris called on:";
 229   if debug then
 230     List.iter debug_prerr buris;
 231   let l = close_db cache_of_processed_baseuri [] buris in
 232   let l = HExtlib.list_uniq (List.fast_sort Pervasives.compare l) in
 233   let l = List.map NUri.uri_of_string l in
 234   debug_prerr "clean_baseuri will remove:";
 235   if debug then
 236     List.iter (fun u -> debug_prerr (NUri.string_of_uri u)) l;
 237   List.iter
 238    (fun baseuri ->
 239      !decompile ~baseuri;
 240      try
 241       let lexiconfile =
 242        LibraryMisc.lexicon_file_of_baseuri
 243         ~must_exist:false ~writable:true ~baseuri
 244       in
 245        HExtlib.safe_remove lexiconfile;
 246        HExtlib.rmdir_descend (Filename.chop_extension lexiconfile)
 247      with Http_getter_types.Key_not_found _ -> ())
 248    (HExtlib.list_uniq (List.fast_sort Pervasives.compare
 249      (List.map NUri.baseuri_of_uri l @ buris)))
 250 *)