X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=components%2Flibrary%2FlibraryDb.ml;h=7ee8427f74086da808c463fac9391a324897efa8;hb=6ad533c972e6c9e9db53f38f972e7c0792160f2e;hp=78cff79482d2f261c5c46c461d65f2a0152f0a69;hpb=15417a6cd2d1ce39afc67d36436864978ec7a8e2;p=helm.git diff --git a/components/library/libraryDb.ml b/components/library/libraryDb.ml index 78cff7948..7ee8427f7 100644 --- a/components/library/libraryDb.ml +++ b/components/library/libraryDb.ml @@ -25,18 +25,37 @@ (* $Id$ *) -open Printf ;; +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 ( - HSql.quick_connect - ~host:(Helm_registry.get "db.host") - ~user:(Helm_registry.get "db.user") - ~database:(Helm_registry.get "db.database") - ()) + 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://" @@ -52,14 +71,18 @@ let clean_owner_environment () = (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) + (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 dbd with + with (HSql.Error _) as exn -> + match HSql.errno dbtype dbd with | HSql.No_such_table -> [] | _ -> raise exn in @@ -70,15 +93,15 @@ let clean_owner_environment () = (fun suffix -> try HExtlib.safe_remove - (Http_getter.resolve ~writable:true (uri ^ suffix)) + (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 dbd statement) - with HSql.Error as exn -> - match HSql.errno dbd with + 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 -> prerr_endline statement; () @@ -106,28 +129,28 @@ let create_owner_environment () = (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 = - (SqlStatements.create_tables system_tbls) @ - (SqlStatements.create_tables tbls) @ - (SqlStatements.create_indexes system_tbls) @ - (SqlStatements.create_indexes tbls) + (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 statement -> - try - ignore (HSql.exec dbd statement) - with - HSql.Error -> - let status = HSql.errno dbd in - match status with - | HSql.Table_exists_error -> () - | HSql.Dup_keyname -> () - | HSql.GENERIC_ERROR _ -> - prerr_endline statement; - raise HSql.Error - | _ -> () - - - ) statements + 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 @@ -147,14 +170,20 @@ let remove_uri uri = 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 then - sprintf "DELETE QUICK LOW_PRIORITY FROM %s WHERE source='%s'" table (HSql.escape suri) - else sprintf "DELETE FROM %s WHERE source='%s'" table (HSql.escape 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 dbd (query t suri)) + ignore (HSql.exec dbtype dbd (query t suri)) with exn -> raise exn (* no errors should be accepted *) ) @@ -164,11 +193,19 @@ let remove_uri uri = 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 - (HSql.escape (UriManager.string_of_uri uri)) + 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 dbd query 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