X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;ds=sidebyside;f=components%2Flibrary%2FlibraryDb.ml;fp=components%2Flibrary%2FlibraryDb.ml;h=e82e91f97f1629295d149ba1d066d11234932218;hb=f61af501fb4608cc4fb062a0864c774e677f0d76;hp=0000000000000000000000000000000000000000;hpb=58ae1809c352e71e7b5530dc41e2bfc834e1aef1;p=helm.git

diff --git a/components/library/libraryDb.ml b/components/library/libraryDb.ml
new file mode 100644
index 000000000..e82e91f97
--- /dev/null
+++ b/components/library/libraryDb.ml
@@ -0,0 +1,212 @@
+(* 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$ *)
+
+let dbtype_of_string dbtype =
+   if dbtype = "library" then HSql.Library
+   else if dbtype = "user" then HSql.User
+   else if dbtype = "legacy" then HSql.Legacy
+   else raise (HSql.Error "HSql: wrong config file format")
+
+let parse_dbd_conf _ =
+  let metadata = Helm_registry.get_list Helm_registry.string "db.metadata" in
+  List.map
+    (fun s -> 
+      match Pcre.split ~pat:"\\s+" s with
+      | [path;db;user;pwd;dbtype] -> 
+           let dbtype = dbtype_of_string dbtype in
+           let pwd = if pwd = "none" then None else Some pwd in
+           (* TODO parse port *)
+           path, None, db, user, pwd, dbtype
+      | _ -> raise (HSql.Error "HSql: Bad format in config file"))
+    metadata
+;;
+
+let parse_dbd_conf _ =
+   HSql.mk_dbspec (parse_dbd_conf ())
+;;
+
+let instance =
+  let dbd = lazy (
+    let dbconf = parse_dbd_conf () in
+    HSql.quick_connect dbconf)
+  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 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 dbtype = 
+    if Helm_registry.get_bool "matita.system" then HSql.Library else HSql.User
+  in
+  let statements = 
+    (SqlStatements.drop_tables tbls) @ 
+    (SqlStatements.drop_indexes tbls dbtype dbd)
+  in
+  let owned_uris =
+    try
+      MetadataDb.clean ~dbd
+    with (HSql.Error _) as exn ->
+      match HSql.errno dbtype dbd with 
+      | HSql.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 ~local:true ~writable:true (uri ^ suffix))
+          with Http_getter_types.Key_not_found _ -> ())
+        [""; ".body"; ".types"])
+    owned_uris;
+  List.iter (fun statement -> 
+    try
+      ignore (HSql.exec dbtype dbd statement)
+    with (HSql.Error _) as exn ->
+      match HSql.errno dbtype dbd with 
+      | HSql.No_such_table
+      | HSql.Bad_table_error
+      | HSql.No_such_index -> ()
+      | _ -> 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 l_obj_tbl = MetadataTypes.library_obj_tbl  in
+  let l_sort_tbl = MetadataTypes.library_sort_tbl  in
+  let l_rel_tbl = MetadataTypes.library_rel_tbl  in
+  let l_name_tbl =  MetadataTypes.library_name_tbl  in
+  let l_count_tbl = MetadataTypes.library_count_tbl  in
+  let tbls = [ 
+    (obj_tbl,`RefObj) ; (sort_tbl,`RefSort) ; (rel_tbl,`RefRel) ;
+    (name_tbl,`ObjectName) ; (count_tbl,`Count) ]
+  in
+  let system_tbls = [ 
+    (l_obj_tbl,`RefObj) ; (l_sort_tbl,`RefSort) ; (l_rel_tbl,`RefRel) ;
+    (l_name_tbl,`ObjectName) ; (l_count_tbl,`Count) ] 
+  in
+  let tag tag l = List.map (fun x -> tag, x) l in
+  let statements = 
+    (tag HSql.Library (SqlStatements.create_tables system_tbls)) @ 
+    (tag HSql.User (SqlStatements.create_tables tbls)) @ 
+    (tag HSql.Library (SqlStatements.create_indexes system_tbls)) @
+    (tag HSql.User (SqlStatements.create_indexes tbls))
+  in
+  List.iter 
+    (fun (dbtype, statement) -> 
+      try
+        ignore (HSql.exec dbtype dbd statement)
+      with
+        (HSql.Error _) as exc -> 
+          let status = HSql.errno dbtype dbd in 
+          match status with 
+          | HSql.Table_exists_error -> ()
+          | HSql.Dup_keyname -> ()
+          | HSql.GENERIC_ERROR _ -> 
+              prerr_endline statement;
+              raise exc
+          | _ -> ())
+  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 dbtype = 
+    if Helm_registry.get_bool "matita.system" then HSql.Library else HSql.User
+  in
+  let query table suri = 
+    if HSql.isMysql dbtype dbd then 
+      Printf.sprintf "DELETE QUICK LOW_PRIORITY FROM %s WHERE source='%s'" table 
+        (HSql.escape dbtype dbd suri)
+    else 
+      Printf.sprintf "DELETE FROM %s WHERE source='%s'" table 
+        (HSql.escape dbtype dbd suri)
+  in
+  List.iter (fun t -> 
+    try 
+      ignore (HSql.exec dbtype 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];
+;;
+
+let xpointers_of_ind uri =
+  let dbd = instance () in
+  let name_tbl =  MetadataTypes.name_tbl () in
+  let dbtype = 
+    if Helm_registry.get_bool "matita.system" then HSql.Library else HSql.User
+  in
+  let escape s =
+    Pcre.replace ~pat:"([^\\\\])_" ~templ:"$1\\_" 
+      (HSql.escape dbtype dbd s)
+  in
+  let query = Printf.sprintf 
+    ("SELECT source FROM %s WHERE source LIKE '%s#xpointer%%' "
+     ^^ HSql.escape_string_for_like dbtype dbd)
+    name_tbl (escape (UriManager.string_of_uri uri))
+  in
+  let rc = HSql.exec dbtype dbd query in
+  let l = ref [] in
+  HSql.iter rc (fun a ->  match a.(0) with None ->()|Some a -> l := a:: !l);
+  List.map UriManager.uri_of_string !l
+