226 lines
7.7 KiB
OCaml
226 lines
7.7 KiB
OCaml
open Geneweb
|
|
open Gwdb
|
|
|
|
let aux txt
|
|
(fn :
|
|
?report:(Fixbase.patch -> unit) -> (int -> int -> unit) -> base -> unit)
|
|
~v1 ~v2 base n cnt =
|
|
let string_of_patch =
|
|
let string_of_p i = Gutil.designation base (poi base i) in
|
|
let string_of_f i =
|
|
let fam = foi base i in
|
|
Printf.sprintf "[%s & %s]"
|
|
(string_of_p @@ get_father fam)
|
|
(string_of_p @@ get_mother fam)
|
|
in
|
|
function
|
|
| Fixbase.Fix_NBDS ip ->
|
|
Printf.sprintf "Fixed pevents for: %s" (string_of_p ip)
|
|
| Fix_AddedUnion ip -> Printf.sprintf "Added union for: %s" (string_of_p ip)
|
|
| Fix_AddedParents ip ->
|
|
Printf.sprintf "Fixed missing parents for: %s" (string_of_p ip)
|
|
| Fix_ParentDeleted ip ->
|
|
Printf.sprintf "Deleted parents for: %s" (string_of_p ip)
|
|
| Fix_AddedChild ifam ->
|
|
Printf.sprintf "Added child in: %s" (string_of_f ifam)
|
|
| Fix_RemovedUnion (ip, ifam) ->
|
|
Printf.sprintf "Removing ifam %s from [%s] unions" (string_of_ifam ifam)
|
|
(string_of_p ip)
|
|
| Fix_RemovedDuplicateUnion (ip, ifam) ->
|
|
Printf.sprintf "Removing duplicate ifam %s from [%s] unions"
|
|
(string_of_ifam ifam) (string_of_p ip)
|
|
| Fix_AddedRelatedFromPevent (ip, ip2) | Fix_AddedRelatedFromFevent (ip, ip2)
|
|
->
|
|
Printf.sprintf "Added related %s to %s" (string_of_p ip2)
|
|
(string_of_p ip)
|
|
| Fix_MarriageDivorce ifam ->
|
|
Printf.sprintf "Fixed marriage and/or divorce info of %s"
|
|
(string_of_f ifam)
|
|
| Fix_MissingSpouse (ifam, iper) ->
|
|
Printf.sprintf "Fixed missing spouse (%s) in family %s"
|
|
(string_of_p iper) (string_of_f ifam)
|
|
| Fix_WrongUTF8Encoding (ifam_opt, iper_opt, opt) ->
|
|
Printf.sprintf "Fixed invalid UTF-8 sequence (%s): %s"
|
|
(match ifam_opt with
|
|
| Some i -> "ifam " ^ string_of_ifam i
|
|
| None -> (
|
|
match iper_opt with
|
|
| Some i -> "iper " ^ string_of_iper i
|
|
| None -> assert false))
|
|
(match opt with
|
|
| Some (i, i') -> string_of_istr i ^ " -> " ^ string_of_istr i'
|
|
| None -> "Dtext")
|
|
| Fix_UpdatedOcc (iper, oocc, nocc) ->
|
|
Printf.sprintf "Uptated occ for %s: %d -> %d" (string_of_p iper) oocc
|
|
nocc
|
|
in
|
|
let i' = ref 0 in
|
|
if v1 then (
|
|
print_endline txt;
|
|
flush stdout;
|
|
ProgrBar.start ());
|
|
let progress =
|
|
if v2 then (fun i n ->
|
|
ProgrBar.run i n;
|
|
i' := i)
|
|
else if v1 then ProgrBar.run
|
|
else fun _ _ -> ()
|
|
in
|
|
let report =
|
|
if v2 then
|
|
Some
|
|
(fun s ->
|
|
incr cnt;
|
|
ProgrBar.suspend ();
|
|
print_endline @@ "\t" ^ string_of_patch s;
|
|
flush stdout;
|
|
ProgrBar.restart !i' n)
|
|
else Some (fun _ -> incr cnt)
|
|
in
|
|
fn ?report progress base;
|
|
if v1 then ProgrBar.finish ()
|
|
|
|
let check_NBDS = aux "Check persons' NBDS" Fixbase.check_NBDS
|
|
|
|
let check_families_parents =
|
|
aux "Check families' parents" Fixbase.check_families_parents
|
|
|
|
let check_families_children =
|
|
aux "Check families' children" Fixbase.check_families_children
|
|
|
|
let check_persons_parents =
|
|
aux "Check persons' parents" Fixbase.check_persons_parents
|
|
|
|
let check_persons_families =
|
|
aux "Check persons' families" Fixbase.check_persons_families
|
|
|
|
let check_pevents_witnesses =
|
|
aux "Check persons' events witnesses" Fixbase.check_pevents_witnesses
|
|
|
|
let check_fevents_witnesses =
|
|
aux "Check family events witnesses" Fixbase.check_fevents_witnesses
|
|
|
|
let fix_marriage_divorce =
|
|
aux "Fix families' marriage and divorce" Fixbase.fix_marriage_divorce
|
|
|
|
let fix_utf8_sequence =
|
|
aux "Fix invalid UTF-8 sequence" Fixbase.fix_utf8_sequence
|
|
|
|
let fix_key = aux "Fix duplicate keys" Fixbase.fix_key
|
|
|
|
let check ~dry_run ~verbosity ~fast ~f_parents ~f_children ~p_parents
|
|
~p_families ~p_NBDS ~pevents_witnesses ~fevents_witnesses ~marriage_divorce
|
|
~invalid_utf8 ~key bname =
|
|
let v1 = !verbosity >= 1 in
|
|
let v2 = !verbosity >= 2 in
|
|
if not v1 then Mutil.verbose := false;
|
|
let fast = !fast in
|
|
let base = Gwdb.open_base bname in
|
|
let fix = ref 0 in
|
|
let nb_fam = nb_of_families base in
|
|
let nb_ind = nb_of_persons base in
|
|
if fast then (
|
|
load_strings_array base;
|
|
load_persons_array base);
|
|
if !f_parents then check_families_parents ~v1 ~v2 base nb_fam fix;
|
|
if !f_children then check_families_children ~v1 ~v2 base nb_fam fix;
|
|
if !p_parents then check_persons_parents ~v1 ~v2 base nb_ind fix;
|
|
if !p_NBDS then check_NBDS base ~v1 ~v2 nb_ind fix;
|
|
if !p_families then check_persons_families ~v1 ~v2 base nb_ind fix;
|
|
if !pevents_witnesses then check_pevents_witnesses ~v1 ~v2 base nb_ind fix;
|
|
if !fevents_witnesses then check_fevents_witnesses ~v1 ~v2 base nb_fam fix;
|
|
if !marriage_divorce then fix_marriage_divorce ~v1 ~v2 base nb_fam fix;
|
|
if !invalid_utf8 then fix_utf8_sequence ~v1 ~v2 base nb_fam fix;
|
|
if !key then fix_key ~v1 ~v2 base nb_ind fix;
|
|
if fast then (
|
|
clear_strings_array base;
|
|
clear_persons_array base);
|
|
if not !dry_run then (
|
|
if !fix <> 0 then (
|
|
Gwdb.commit_patches base;
|
|
if v1 then (
|
|
Printf.printf "%n changes commited\n" !fix;
|
|
flush stdout))
|
|
else if v1 then (
|
|
Printf.printf "No change\n";
|
|
flush stdout);
|
|
if v1 then (
|
|
Printf.printf "Rebuilding the indexes..\n";
|
|
flush stdout);
|
|
Gwdb.sync base;
|
|
if v1 then (
|
|
Printf.printf "Done";
|
|
flush stdout))
|
|
|
|
(**/**)
|
|
|
|
let bname = ref ""
|
|
let verbosity = ref 2
|
|
let fast = ref false
|
|
let f_parents = ref false
|
|
let f_children = ref false
|
|
let p_parents = ref false
|
|
let p_families = ref false
|
|
let p_NBDS = ref false
|
|
let pevents_witnesses = ref false
|
|
let fevents_witnesses = ref false
|
|
let marriage_divorce = ref false
|
|
let invalid_utf8 = ref false
|
|
let key = ref false
|
|
let index = ref false
|
|
let dry_run = ref false
|
|
|
|
let speclist =
|
|
[
|
|
("-dry-run", Arg.Set dry_run, " do not commit changes (only print)");
|
|
("-q", Arg.Unit (fun () -> verbosity := 1), " quiet mode");
|
|
("-qq", Arg.Unit (fun () -> verbosity := 0), " very quiet mode");
|
|
("-fast", Arg.Set fast, " fast mode. Needs more memory.");
|
|
("-families-parents", Arg.Set f_parents, " missing doc");
|
|
("-families-children", Arg.Set f_children, " missing doc");
|
|
("-persons-NBDS", Arg.Set p_parents, " missing doc");
|
|
("-persons-parents", Arg.Set p_parents, " missing doc");
|
|
("-persons-families", Arg.Set p_families, " missing doc");
|
|
("-pevents-witnesses", Arg.Set pevents_witnesses, " missing doc");
|
|
("-fevents-witnesses", Arg.Set fevents_witnesses, " missing doc");
|
|
("-marriage-divorce", Arg.Set marriage_divorce, " missing doc");
|
|
("-person-key", Arg.Set key, " missing doc");
|
|
( "-index",
|
|
Arg.Set index,
|
|
" rebuild index. It is automatically enable by any other option." );
|
|
("-invalid-utf8", Arg.Set invalid_utf8, " missing doc");
|
|
]
|
|
|
|
let anonfun i = bname := i
|
|
let usage = "Usage: " ^ Sys.argv.(0) ^ " [OPTION] base"
|
|
|
|
let main () =
|
|
Arg.parse speclist anonfun usage;
|
|
Secure.set_base_dir (Filename.dirname !bname);
|
|
if !bname = "" then (
|
|
Arg.usage speclist usage;
|
|
exit 2);
|
|
Lock.control (Mutil.lock_file !bname) false ~onerror:Lock.print_try_again
|
|
@@ fun () ->
|
|
if
|
|
!f_parents || !f_children || !p_parents || !p_families || !pevents_witnesses
|
|
|| !fevents_witnesses || !marriage_divorce || !p_NBDS || !invalid_utf8
|
|
|| !key || !index
|
|
then ()
|
|
else (
|
|
f_parents := true;
|
|
f_children := true;
|
|
p_parents := true;
|
|
p_families := true;
|
|
pevents_witnesses := true;
|
|
fevents_witnesses := true;
|
|
marriage_divorce := true;
|
|
p_NBDS := true;
|
|
invalid_utf8 := true;
|
|
key := true);
|
|
check ~dry_run ~fast ~verbosity ~f_parents ~f_children ~p_NBDS ~p_parents
|
|
~p_families ~pevents_witnesses ~fevents_witnesses ~marriage_divorce
|
|
~invalid_utf8 ~key !bname
|
|
|
|
let _ = main ()
|