X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=components%2Flibrary%2FlibraryDb.ml;h=e82e91f97f1629295d149ba1d066d11234932218;hb=65662e7d8de61a338b636f208d04e85eb59e6b8e;hp=83bc3f6e67ace89cb334b86fa754d4d812d43d05;hpb=946f85ff8a6cbfd3712a73919cdadc4d99916971;p=helm.git diff --git a/components/library/libraryDb.ml b/components/library/libraryDb.ml index 83bc3f6e6..e82e91f97 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 + match HSql.errno dbtype dbd with | HSql.No_such_table -> [] | _ -> raise exn in @@ -70,18 +93,18 @@ 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) + ignore (HSql.exec dbtype dbd statement) with (HSql.Error _) as exn -> - match HSql.errno dbd with + match HSql.errno dbtype dbd with | HSql.No_such_table | HSql.Bad_table_error - | HSql.No_such_index -> prerr_endline statement; () + | HSql.No_such_index -> () | _ -> raise exn ) statements; ;; @@ -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 _) as exc -> - let status = HSql.errno dbd in - match status with - | HSql.Table_exists_error -> () - | HSql.Dup_keyname -> () - | HSql.GENERIC_ERROR _ -> - prerr_endline statement; - raise exc - | _ -> () - - - ) 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