]> matita.cs.unibo.it Git - helm.git/blob - matitaB/components/library/libraryClean.ml
update in delayed_updating
[helm.git] / matitaB / 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 open Printf
29
30 let debug = false
31 let debug_prerr = if debug then prerr_endline else ignore
32
33 module HGT = Http_getter_types;;
34 module HG = Http_getter;;
35 (*module UM = UriManager;;*)
36
37 let decompile = ref (fun ~baseuri -> assert false);;
38 let set_decompile_cb f = decompile := f;;
39
40 (*
41 let strip_xpointer s = Pcre.replace ~pat:"#.*$" s ;;
42
43 let safe_buri_of_suri suri =
44   try
45     UM.buri_of_uri (UM.uri_of_string suri)
46   with
47     UM.IllFormedUri _ -> suri
48
49 let one_step_depend cache_of_processed_baseuri suri dbtype dbd =
50   assert false (* MATITA 1.0
51   let buri = safe_buri_of_suri suri in
52   if Hashtbl.mem cache_of_processed_baseuri buri then 
53     []
54   else
55     begin
56       Hashtbl.add cache_of_processed_baseuri buri true;
57       let query = 
58         let buri = buri ^ "/" in 
59         let buri = HSql.escape dbtype dbd buri in
60         let obj_tbl = MetadataTypes.obj_tbl () in
61         if HSql.isMysql dbtype dbd then        
62           sprintf ("SELECT source, h_occurrence FROM %s WHERE " 
63             ^^ "h_occurrence REGEXP '"^^
64             "^%s\\([^/]+\\|[^/]+#xpointer.*\\)$"^^"'")
65           obj_tbl buri
66         else
67           begin
68             sprintf ("SELECT source, h_occurrence FROM %s WHERE " 
69             ^^ "REGEXP(h_occurrence, '"^^
70             "^%s\\([^/]+\\|[^/]+#xpointer.*\\)$"^^"')")
71             obj_tbl buri
72             (* implementation with vanilla ocaml-sqlite3
73             HLog.debug "Warning SELECT without REGEXP";
74             sprintf
75               ("SELECT source, h_occurrence FROM %s WHERE " ^^ 
76                "h_occurrence LIKE '%s%%' " ^^ HSql.escape_string_for_like)
77                   obj_tbl buri*)
78           end
79       in
80       try 
81         let rc = HSql.exec dbtype dbd query in
82         let l = ref [] in
83         HSql.iter rc (
84           fun row -> 
85             match row.(0), row.(1) with 
86             | Some uri, Some occ when 
87                 Filename.dirname (strip_xpointer occ) = buri -> 
88                   l := uri :: !l
89             | _ -> ());
90         let l = List.sort Pervasives.compare !l in
91         HExtlib.list_uniq l
92       with
93         exn -> raise exn (* no errors should be accepted *)
94     end
95     *)
96     
97 let db_uris_of_baseuri buri =
98   [] (* MATITA 1.0
99  let dbd = LibraryDb.instance () in
100  let dbtype = 
101    if Helm_registry.get_bool "matita.system" then HSql.Library else HSql.User
102  in
103  let query = 
104   let buri = buri ^ "/" in 
105   let buri = HSql.escape dbtype dbd buri in
106   let obj_tbl = MetadataTypes.name_tbl () in
107   if HSql.isMysql dbtype dbd then        
108     sprintf ("SELECT source FROM %s WHERE " 
109     ^^ "source REGEXP '^%s[^/]*(#xpointer.*)?$'") obj_tbl buri
110   else
111    begin
112     sprintf ("SELECT source FROM %s WHERE " 
113       ^^ "REGEXP(source, '^%s[^/]*\\(#xpointer.*\\)?$')") obj_tbl buri
114    end
115  in
116  try 
117   let rc = HSql.exec dbtype dbd query in
118   let l = ref [] in
119   HSql.iter rc (
120     fun row -> 
121       match row.(0) with 
122       | Some uri when Filename.dirname (strip_xpointer uri) = buri -> 
123           l := uri :: !l
124       | _ -> ());
125   let l = List.sort Pervasives.compare !l in
126   HExtlib.list_uniq l
127  with
128   exn -> raise exn (* no errors should be accepted *)
129   *)
130 ;;
131
132 let close_uri_list cache_of_processed_baseuri uri_to_remove =
133   let dbd = LibraryDb.instance () in
134   let dbtype = 
135     if Helm_registry.get_bool "matita.system" then HSql.Library else HSql.User
136   in
137   (* to remove an uri you have to remove the whole script *)
138   let buri_to_remove = 
139     HExtlib.list_uniq 
140       (List.fast_sort Pervasives.compare 
141         (List.map safe_buri_of_suri uri_to_remove))
142   in
143   (* cleand the already visided baseuris *)
144   let buri_to_remove = 
145     List.filter 
146       (fun buri -> 
147         if Hashtbl.mem cache_of_processed_baseuri buri then false
148         else true)
149       buri_to_remove
150   in
151   (* now calculate the list of objects that belong to these baseuris *)
152   let uri_to_remove = 
153     try
154       List.fold_left 
155         (fun acc buri ->
156           let inhabitants = HG.ls ~local:true (buri ^ "/") in
157           let inhabitants = List.filter 
158               (function HGT.Ls_object _ -> true | _ -> false) 
159             inhabitants
160           in
161           let inhabitants = List.map 
162               (function 
163                | HGT.Ls_object e -> buri ^ "/" ^ e.HGT.uri 
164                | _ -> assert false)
165             inhabitants
166           in
167           inhabitants @ acc)
168       [] buri_to_remove 
169     with HGT.Invalid_URI u -> 
170       HLog.error ("We were listing an invalid buri: " ^ u);
171       exit 1
172   in
173   let uri_to_remove_from_db =
174    List.fold_left 
175      (fun acc buri -> 
176        let dbu = db_uris_of_baseuri buri in
177        dbu @ acc
178      ) [] buri_to_remove 
179   in
180   let uri_to_remove = uri_to_remove @ uri_to_remove_from_db in
181   let uri_to_remove =
182    HExtlib.list_uniq (List.sort Pervasives.compare uri_to_remove) in
183   (* now we want the list of all uri that depend on them *) 
184   let depend = 
185     List.fold_left
186     (fun acc u -> one_step_depend cache_of_processed_baseuri u dbtype dbd @ acc)
187     [] uri_to_remove
188   in
189   let depend = 
190     HExtlib.list_uniq (List.fast_sort Pervasives.compare depend) 
191   in
192   uri_to_remove, depend
193 ;;
194
195 let rec close_db cache_of_processed_baseuri uris next =
196   match next with
197   | [] -> uris
198   | l -> 
199      let uris, next = close_uri_list cache_of_processed_baseuri l in
200      close_db cache_of_processed_baseuri uris next @ uris
201 ;;
202   
203 let cleaned_no = ref 0;;
204
205   (** TODO repellent code ... *)
206 let moo_root_dir = lazy (
207   let url =
208     List.assoc "cic:/matita/"
209       (List.map
210         (fun pair ->
211           match
212             Str.split (Str.regexp "[ \t\r\n]+") (HExtlib.trim_blanks pair)
213           with
214           | a::b::_ -> a, b
215           | _ -> assert false)
216         (Helm_registry.get_list Helm_registry.string "getter.prefix"))
217   in
218   String.sub url 7 (String.length url - 7))
219 ;;
220 *)
221
222 let rec close_db cache_of_processed_baseuri uris next =
223   uris (* MATITA 1.0 *)
224 ;;
225
226 let clean_baseuris ?(verbose=true) buris =
227  (* MATITA 1.0 *) () (*
228   let cache_of_processed_baseuri = Hashtbl.create 1024 in
229   let buris = List.map Http_getter_misc.strip_trailing_slash buris in
230   debug_prerr "clean_baseuris called on:";
231   if debug then
232     List.iter debug_prerr buris; 
233   let l = close_db cache_of_processed_baseuri [] buris in
234   let l = HExtlib.list_uniq (List.fast_sort Pervasives.compare l) in
235   let l = List.map NUri.uri_of_string l in
236   debug_prerr "clean_baseuri will remove:";
237   if debug then
238     List.iter (fun u -> debug_prerr (NUri.string_of_uri u)) l; 
239   List.iter
240    (fun baseuri ->
241      !decompile ~baseuri;
242      try 
243       let lexiconfile =
244        LibraryMisc.lexicon_file_of_baseuri 
245         ~must_exist:false ~writable:true ~baseuri
246       in
247        HExtlib.safe_remove lexiconfile;
248        HExtlib.rmdir_descend (Filename.chop_extension lexiconfile)
249      with Http_getter_types.Key_not_found _ -> ())
250    (HExtlib.list_uniq (List.fast_sort Pervasives.compare
251      (List.map NUri.baseuri_of_uri l @ buris)))
252 *)