X-Git-Url: http://matita.cs.unibo.it/gitweb/?p=helm.git;a=blobdiff_plain;f=helm%2Focaml%2Flibrary%2FlibraryDb.ml;fp=helm%2Focaml%2Flibrary%2FlibraryDb.ml;h=f0404336622b57333369a9be4d3d45f3c0745cfc;hp=0000000000000000000000000000000000000000;hb=792b5d29ebae8f917043d9dd226692919b5d6ca1;hpb=a14a8c7637fd0b95e9d4deccb20c6abc98e8f953 diff --git a/helm/ocaml/library/libraryDb.ml b/helm/ocaml/library/libraryDb.ml new file mode 100644 index 000000000..f04043366 --- /dev/null +++ b/helm/ocaml/library/libraryDb.ml @@ -0,0 +1,168 @@ +(* Copyright (C) 2004-2005, HELM Team. + * + * This file is part of HELM, an Hypertextual, Electronic + * Library of Mathematics, developed at the Computer Science + * Department, University of Bologna, Italy. + * + * HELM is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * HELM is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with HELM; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, + * MA 02111-1307, USA. + * + * For details, see the HELM World-Wide-Web page, + * http://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf ;; + +let instance = + let dbd = lazy ( + HMysql.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 file_scheme_RE = Pcre.regexp "^file://" + +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 count_tbl = MetadataTypes.count_tbl () in + let tbls = [ + (obj_tbl,`RefObj) ; (sort_tbl,`RefSort) ; (rel_tbl,`RefRel) ; + (name_tbl,`ObjectName) ; (count_tbl,`Count) ] + in + let statements = + (SqlStatements.drop_tables tbls) @ (SqlStatements.drop_indexes tbls) + in + let owned_uris = + try + MetadataDb.clean ~dbd + with Mysql.Error _ as exn -> + match HMysql.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 -> + try + HExtlib.safe_remove (Http_getter.resolve (uri ^ suffix)) + with Http_getter_types.Key_not_found _ -> ()) + [""; ".body"; ".types"]) + owned_uris; + List.iter (fun statement -> + try + ignore (HMysql.exec dbd statement) + with Mysql.Error _ as exn -> + match HMysql.errno dbd with + | Mysql.Bad_table_error + | Mysql.No_such_index | Mysql.No_such_table -> () + | _ -> raise exn + ) statements; +;; + +let create_owner_environment () = + let dbd = instance () 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 count_tbl = MetadataTypes.count_tbl () in + let tbls = [ + (obj_tbl,`RefObj) ; (sort_tbl,`RefSort) ; (rel_tbl,`RefRel) ; + (name_tbl,`ObjectName) ; (count_tbl,`Count) ] + in + let statements = + (SqlStatements.create_tables tbls) @ (SqlStatements.create_indexes tbls) + in + List.iter (fun statement -> + try + ignore (HMysql.exec dbd statement) + with + exn -> + let status = HMysql.status dbd in + match status with + | Mysql.StatusError Mysql.Table_exists_error -> () + | Mysql.StatusError Mysql.Dup_keyname -> () + | Mysql.StatusError _ -> raise exn + | _ -> () + ) 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 check 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 count_tbl = MetadataTypes.count_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 (HMysql.escape suri) + in + List.iter (fun t -> + try + ignore (HMysql.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*)count_tbl]; + (* and now the debug job *) + let dbg_q = + sprintf "SELECT source FROM %s WHERE h_occurrence LIKE '%s%%'" obj_tbl + (HMysql.escape suri) + in + try + let rc = HMysql.exec dbd dbg_q in + let l = ref [] in + HMysql.iter rc (fun a -> match a.(0) with None ->()|Some a -> l := a:: !l); + let l = List.sort Pervasives.compare !l in + HExtlib.list_uniq l + with + exn -> raise exn (* no errors should be accepted *) + +let xpointers_of_ind uri = + let dbd = instance () in + let name_tbl = MetadataTypes.name_tbl () in + let query = sprintf + "SELECT source FROM %s WHERE source LIKE '%s#xpointer%%'" name_tbl + (HMysql.escape (UriManager.string_of_uri uri)) + in + let rc = HMysql.exec dbd query in + let l = ref [] in + HMysql.iter rc (fun a -> match a.(0) with None ->()|Some a -> l := a:: !l); + List.map UriManager.uri_of_string !l +