1 (* Copyright (C) 2005, HELM Team.
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.
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.
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.
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,
22 * For details, see the HELM World-Wide-Web page,
23 * http://helm.cs.unibo.it/
27 let debug_prerr = if debug then prerr_endline else ignore
29 module HGT = Http_getter_types;;
30 module HG = Http_getter;;
31 module HGM = Http_getter_misc;;
32 module UM = UriManager;;
33 module TA = GrafiteAst;;
35 let baseuri_of_baseuri_decl st =
37 | TA.Executable (_, TA.Command (_, TA.Set (_, "baseuri", buri))) ->
41 let cache_of_processed_baseuri = Hashtbl.create 1024
43 let one_step_depend suri =
46 UM.buri_of_uri (UM.uri_of_string suri)
47 with UM.IllFormedUri _ -> suri
49 if Hashtbl.mem cache_of_processed_baseuri buri then
53 Hashtbl.add cache_of_processed_baseuri buri true;
55 let buri = buri ^ "/" in
56 let buri = Mysql.escape buri in
57 let obj_tbl = MetadataTypes.obj_tbl () in
59 "SELECT source, h_occurrence FROM %s WHERE h_occurrence LIKE '%s%%'" obj_tbl buri
62 let rc = Mysql.exec (MatitaDb.instance ()) query in
66 match row.(0), row.(1) with
67 | Some uri, Some occ when Filename.dirname occ = buri ->
70 let l = List.sort Pervasives.compare !l in
71 MatitaMisc.list_uniq l
73 exn -> raise exn (* no errors should be accepted *)
77 let safe_buri_of_suri suri =
79 UM.buri_of_uri (UM.uri_of_string suri)
81 UM.IllFormedUri _ -> suri
83 let close_uri_list uri_to_remove =
84 (* to remove an uri you have to remove the whole script *)
87 (List.fast_sort Pervasives.compare
88 (List.map safe_buri_of_suri uri_to_remove))
90 (* cleand the already visided baseuris *)
94 if Hashtbl.mem cache_of_processed_baseuri buri then false
98 (* now calculate the list of objects that belong to these baseuris *)
103 let inhabitants = HG.ls (buri ^ "/") in
104 let inhabitants = List.filter
105 (function HGT.Ls_object _ -> true | _ -> false)
108 let inhabitants = List.map
110 | HGT.Ls_object e -> buri ^ "/" ^ e.HGT.uri
116 with HGT.Invalid_URI u ->
117 MatitaLog.error ("We were listing an invalid buri: " ^ u);
120 (* now we want the list of all uri that depend on them *)
123 (fun acc u -> one_step_depend u @ acc) [] uri_to_remove
127 (List.fast_sort Pervasives.compare depend)
129 uri_to_remove, depend
131 let baseuri_of_file file =
132 let uri = ref None in
133 let ic = open_in file in
134 let istream = Stream.of_channel ic in
137 let stm = GrafiteParser.parse_statement istream in
138 match baseuri_of_baseuri_decl stm with
140 let u = MatitaMisc.strip_trailing_slash buri in
141 if String.length u < 5 || String.sub u 0 5 <> "cic:/" then
142 MatitaLog.error (file ^ " sets an incorrect baseuri: " ^ buri);
146 | HGT.Unresolvable_URI _ ->
147 MatitaLog.error (file ^ " sets an unresolvable baseuri: "^buri)
148 | HGT.Key_not_found _ -> ());
153 with End_of_file -> close_in ic);
156 | None -> failwith ("No baseuri defined in " ^ file)
158 let rec fix uris next =
161 | l -> let uris, next = close_uri_list l in fix uris next @ uris
163 let clean_baseuris ?(verbose=true) buris =
164 Hashtbl.clear cache_of_processed_baseuri;
165 let buris = List.map HGM.strip_trailing_slash buris in
166 debug_prerr "clean_baseuris called on:";
168 List.iter debug_prerr buris;
169 let l = fix [] buris in
170 let l = MatitaMisc.list_uniq (List.fast_sort Pervasives.compare l) in
171 let l = List.map UriManager.uri_of_string l in
172 debug_prerr "clean_baseuri will remove:";
174 List.iter (fun u -> debug_prerr (UriManager.string_of_uri u)) l;
175 List.iter (MatitaSync.remove ~verbose) l
177 let is_empty buri = HG.ls (HGM.strip_trailing_slash buri ^ "/") = []