442 lines
17 KiB
OCaml
442 lines
17 KiB
OCaml
(* Copyright (c) 1998-2007 INRIA *)
|
|
|
|
open Config
|
|
open Def
|
|
open Gwdb
|
|
open Util
|
|
open MergeInd
|
|
|
|
let print_differences conf base branches p1 p2 =
|
|
let gen_string_field chk1 chk2 (title : Adef.safe_string)
|
|
(name : Adef.encoded_string) proj =
|
|
let name = (name :> string) in
|
|
let x1 : Adef.safe_string = proj p1 in
|
|
let x2 : Adef.safe_string = proj p2 in
|
|
if
|
|
(x1 :> string) <> ""
|
|
&& (x1 :> string) <> "?"
|
|
&& (x2 :> string) <> ""
|
|
&& (x2 :> string) <> "?"
|
|
&& x1 <> x2
|
|
then (
|
|
let aux i x chk =
|
|
Output.print_sstring conf
|
|
{|<div class="custom-control custom-radio ml-3">|};
|
|
Output.print_sstring conf
|
|
{|<input class="custom-control-input" type="radio" id="|};
|
|
Output.print_sstring conf name;
|
|
Output.print_sstring conf (string_of_int i);
|
|
Output.print_sstring conf {|" name="|};
|
|
Output.print_sstring conf name;
|
|
Output.print_sstring conf {|" value="|};
|
|
Output.print_sstring conf (string_of_int i);
|
|
Output.print_sstring conf {|"|};
|
|
if chk then Output.print_sstring conf " checked";
|
|
Output.print_sstring conf {|>|};
|
|
Output.printf conf {|<label class="custom-control-label" for="|};
|
|
Output.print_sstring conf name;
|
|
Output.print_sstring conf (string_of_int i);
|
|
Output.print_sstring conf {|">|};
|
|
Output.print_string conf x;
|
|
Output.print_sstring conf {|</label></div>|}
|
|
in
|
|
Output.print_sstring conf "<h4>";
|
|
Output.print_string conf (Adef.safe_fn Utf8.capitalize_fst title);
|
|
Output.print_sstring conf {|</h4>|};
|
|
aux 1 x1 chk1;
|
|
aux 2 x2 chk2)
|
|
in
|
|
let string_field = gen_string_field true false in
|
|
Output.print_sstring conf {|<form method="post" action="|};
|
|
Output.print_sstring conf conf.command;
|
|
Output.print_sstring conf {|">|};
|
|
Output.print_sstring conf "<p>\n";
|
|
Util.hidden_env conf;
|
|
Util.hidden_input conf "m" (Adef.encoded "MRG_IND_OK");
|
|
Util.hidden_input conf "i1" (get_iper p1 |> string_of_iper |> Mutil.encode);
|
|
Util.hidden_input conf "i2" (get_iper p2 |> string_of_iper |> Mutil.encode);
|
|
let rec loop = function
|
|
| [ (ip1, ip2) ] ->
|
|
Util.hidden_input conf "ini1" (ip1 |> string_of_iper |> Mutil.encode);
|
|
Util.hidden_input conf "ini2" (ip2 |> string_of_iper |> Mutil.encode)
|
|
| _ :: branches -> loop branches
|
|
| [] -> ()
|
|
in
|
|
loop branches;
|
|
(match (p_getenv conf.env "m", p_getint conf.env "ip") with
|
|
| Some "MRG_DUP_IND_Y_N", Some ip ->
|
|
Util.hidden_input conf "ip" (ip |> string_of_int |> Adef.encoded);
|
|
List.iter
|
|
(fun excl ->
|
|
match p_getenv conf.env excl with
|
|
| None | Some "" -> ()
|
|
| Some s -> Util.hidden_input conf excl (Mutil.encode s))
|
|
[ "iexcl"; "fexcl" ]
|
|
| _ -> ());
|
|
Output.print_sstring conf "</p><p>";
|
|
string_field
|
|
(transl_nth conf "first name/first names" 0 |> Adef.safe)
|
|
("first_name" |> Adef.encoded)
|
|
(fun p -> (p_first_name base p |> escape_html :> Adef.safe_string));
|
|
string_field
|
|
(transl_nth conf "surname/surnames" 0 |> Adef.safe)
|
|
("surname" |> Adef.encoded)
|
|
(fun p -> (p_surname base p |> escape_html :> Adef.safe_string));
|
|
let select_smallest_num = p_first_name base p1 = p_first_name base p2 in
|
|
gen_string_field
|
|
(get_occ p1 < get_occ p2 || not select_smallest_num)
|
|
(get_occ p1 > get_occ p2 && select_smallest_num)
|
|
(transl conf "number" |> Adef.safe)
|
|
("number" |> Adef.encoded)
|
|
(fun p -> get_occ p |> string_of_int |> Adef.safe);
|
|
string_field
|
|
(transl_nth conf "image/images" 0 |> Adef.safe)
|
|
("image" |> Adef.encoded)
|
|
(fun p ->
|
|
match Image.get_portrait conf base p with
|
|
| Some (`Url url) ->
|
|
({|<img src="|} ^<^ escape_html url
|
|
^>^ {|" style="max-width:75px;max-height:100px">|} ^ url
|
|
:> Adef.safe_string)
|
|
| Some (`Path path) ->
|
|
let k = Image.default_portrait_filename base p in
|
|
let s = Unix.stat path in
|
|
Printf.sprintf
|
|
{|<img src="%sm=IM&d=%s&%s&k=%s" \
|
|
style="max-width:75px;max-height:100px"> %s|}
|
|
(commd conf :> string)
|
|
(string_of_int
|
|
@@ int_of_float (mod_float s.Unix.st_mtime (float_of_int max_int)))
|
|
(acces conf base p : Adef.escaped_string :> string)
|
|
k path
|
|
|> Adef.safe
|
|
| None -> Adef.safe "");
|
|
string_field
|
|
(transl conf "public name" |> Adef.safe)
|
|
("public_name" |> Adef.encoded)
|
|
(fun p ->
|
|
(get_public_name p |> sou base |> escape_html :> Adef.safe_string));
|
|
string_field
|
|
(transl_nth conf "occupation/occupations" 0 |> Adef.safe)
|
|
("occupation" |> Adef.encoded)
|
|
(fun p -> (get_occupation p |> sou base |> escape_html :> Adef.safe_string));
|
|
string_field
|
|
(transl conf "sex" |> Adef.safe)
|
|
("sex" |> Adef.encoded)
|
|
(fun p ->
|
|
Adef.safe
|
|
@@ match get_sex p with Male -> "M" | Female -> "F" | Neuter -> "");
|
|
let date_field trans name get =
|
|
string_field
|
|
(transl conf trans |> Adef.safe)
|
|
name
|
|
(fun p ->
|
|
match Date.od_of_cdate (get p) with
|
|
| None -> Adef.safe ""
|
|
| Some d -> DateDisplay.string_of_ondate conf d)
|
|
in
|
|
let place_field trans name get =
|
|
string_field
|
|
(transl conf trans ^<^ Adef.safe " / "
|
|
^>^ transl_nth conf "place/places" 0)
|
|
name
|
|
(fun p -> get p |> sou base |> safe_html)
|
|
in
|
|
date_field "birth" (Adef.encoded "birth") get_birth;
|
|
place_field "birth" (Adef.encoded "birth_place") get_birth_place;
|
|
date_field "baptism" (Adef.encoded "baptism") get_baptism;
|
|
place_field "baptism" (Adef.encoded "baptism_place") get_baptism_place;
|
|
string_field
|
|
(transl conf "death" |> Adef.safe)
|
|
(Adef.encoded "death")
|
|
(fun p ->
|
|
let is = 2 in
|
|
match get_death p with
|
|
| NotDead -> transl_nth conf "alive" is |> Adef.safe
|
|
| Death (dr, cd) ->
|
|
let s =
|
|
match dr with
|
|
| Killed -> transl_nth conf "killed (in action)" is
|
|
| Murdered -> transl_nth conf "murdered" is
|
|
| Executed -> transl_nth conf "executed (legally killed)" is
|
|
| Disappeared -> transl_nth conf "disappeared" is
|
|
| Unspecified -> transl_nth conf "died" is
|
|
in
|
|
s ^<^ " "
|
|
^<^ DateDisplay.string_of_ondate conf (Date.date_of_cdate cd)
|
|
| DeadYoung -> transl_nth conf "died young" is |> Adef.safe
|
|
| DeadDontKnowWhen -> transl_nth conf "died" is |> Adef.safe
|
|
| DontKnowIfDead | OfCourseDead -> Adef.safe "");
|
|
place_field "death" (Adef.encoded "death_place") get_death_place;
|
|
string_field
|
|
(transl conf "burial" |> Adef.safe)
|
|
(Adef.encoded "burial")
|
|
(fun p ->
|
|
let is = 2 in
|
|
(* TODO burial_to_string *)
|
|
match get_burial p with
|
|
| UnknownBurial -> Adef.safe ""
|
|
| Buried cod -> (
|
|
transl_nth conf "buried" is
|
|
^<^
|
|
match Date.od_of_cdate cod with
|
|
| None -> Adef.safe ""
|
|
| Some d -> " " ^<^ DateDisplay.string_of_ondate conf d)
|
|
| Cremated cod -> (
|
|
transl_nth conf "cremated" is
|
|
^<^
|
|
match Date.od_of_cdate cod with
|
|
| None -> Adef.safe ""
|
|
| Some d -> " " ^<^ DateDisplay.string_of_ondate conf d));
|
|
place_field "burial" (Adef.encoded "burial_place") get_burial_place;
|
|
Output.print_sstring conf
|
|
{|</p><p><button type="submit" class="btn btn-primary btn-lg">|};
|
|
Output.print_sstring conf
|
|
(Utf8.capitalize_fst (transl_nth conf "validate/delete" 0));
|
|
Output.print_sstring conf {|</button></form>|}
|
|
|
|
let propose_merge_ind conf base branches p1 p2 =
|
|
let title _ =
|
|
let s = transl_nth conf "person/persons" 1 in
|
|
Output.print_sstring conf
|
|
(Utf8.capitalize_fst (transl_decline conf "merge" s))
|
|
in
|
|
Hutil.header conf title;
|
|
if branches <> [] then (
|
|
Output.print_sstring conf
|
|
(Utf8.capitalize_fst (transl conf "you must first merge"));
|
|
Output.print_sstring conf (transl conf ":");
|
|
Output.print_sstring conf "<ul><li><a href=\"";
|
|
Output.print_string conf (commd conf);
|
|
Output.print_string conf (acces conf base p1);
|
|
Output.print_sstring conf "\">";
|
|
MergeDisplay.print_someone conf base p1;
|
|
Output.print_sstring conf "</a> ";
|
|
Output.print_sstring conf (transl_nth conf "and" 0);
|
|
Output.print_sstring conf " <a href=\"";
|
|
Output.print_string conf (commd conf);
|
|
Output.print_string conf (acces conf base p2);
|
|
Output.print_sstring conf "\">";
|
|
MergeDisplay.print_someone conf base p2;
|
|
Output.print_sstring conf "</a></li></ul><p></p>");
|
|
print_differences conf base branches p1 p2;
|
|
if branches <> [] then (
|
|
Output.print_sstring conf "<p><hr></p><p>";
|
|
Output.print_sstring conf
|
|
(Utf8.capitalize_fst (transl_nth conf "branch/branches" 1));
|
|
Output.print_sstring conf (transl conf ":");
|
|
Output.print_sstring conf "</p><table>";
|
|
List.iter
|
|
(fun (ip1, ip2) ->
|
|
let p1 = poi base ip1 in
|
|
let p2 = poi base ip2 in
|
|
Output.print_sstring conf "<tr align=\"";
|
|
Output.print_sstring conf conf.left;
|
|
Output.print_sstring conf "\"><td>";
|
|
Output.print_string conf (referenced_person_text conf base p1);
|
|
Output.print_string conf (DateDisplay.short_dates_text conf base p1);
|
|
Output.print_sstring conf "</td><td>";
|
|
Output.print_string conf (referenced_person_text conf base p2);
|
|
Output.print_string conf (DateDisplay.short_dates_text conf base p2);
|
|
Output.print_sstring conf "</td></tr>")
|
|
((get_iper p1, get_iper p2) :: branches);
|
|
Output.print_sstring conf "</table>");
|
|
Hutil.trailer conf
|
|
|
|
let error_loop conf base p =
|
|
let title _ =
|
|
transl conf "error" |> Utf8.capitalize_fst |> Output.print_sstring conf
|
|
in
|
|
Hutil.rheader conf title;
|
|
Output.print_sstring conf "<strong>";
|
|
Output.print_string conf (p_first_name base p |> escape_html);
|
|
if get_occ p <> 0 then (
|
|
Output.print_sstring conf ".";
|
|
Output.print_sstring conf (get_occ p |> string_of_int));
|
|
Output.print_sstring conf " ";
|
|
Output.print_string conf (p_surname base p |> escape_html);
|
|
Output.print_sstring conf " ";
|
|
Output.print_sstring conf (transl conf "would be his/her own ancestor");
|
|
Output.print_sstring conf "";
|
|
Hutil.trailer conf
|
|
|
|
let propose_merge_fam conf base branches fam1 fam2 p1 p2 =
|
|
let title _ =
|
|
transl_nth conf "family/families" 1
|
|
|> transl_decline conf "merge"
|
|
|> Utf8.capitalize_fst |> Output.print_sstring conf
|
|
in
|
|
Hutil.header conf title;
|
|
transl conf "you must first merge the 2 families"
|
|
|> Utf8.capitalize_fst |> Output.print_sstring conf;
|
|
Output.print_sstring conf (transl conf ":");
|
|
Output.print_sstring conf " ";
|
|
Output.print_sstring conf "<ul><li><a href=\"";
|
|
Output.print_string conf (commd conf);
|
|
Output.print_string conf (acces conf base p1);
|
|
Output.print_sstring conf "\">";
|
|
MergeDisplay.print_someone conf base p1;
|
|
Output.print_sstring conf "</a> ";
|
|
Output.print_sstring conf (transl conf "with");
|
|
Output.print_sstring conf " <a href=\"";
|
|
Output.print_string conf (commd conf);
|
|
Output.print_string conf (acces conf base p2);
|
|
Output.print_sstring conf "\">";
|
|
MergeDisplay.print_someone conf base p2;
|
|
Output.print_sstring conf "</a></li></ul><p>";
|
|
MergeFamDisplay.print_differences conf base branches fam1 fam2;
|
|
Hutil.trailer conf
|
|
|
|
let not_found_or_incorrect conf =
|
|
let title _ =
|
|
transl conf "error" |> Utf8.capitalize_fst |> Output.print_sstring conf
|
|
in
|
|
Hutil.rheader conf title;
|
|
Output.print_sstring conf (Utf8.capitalize_fst (transl conf "not found"));
|
|
Output.print_sstring conf " ";
|
|
Output.print_sstring conf (transl conf "or");
|
|
Output.print_sstring conf " ";
|
|
Output.print_sstring conf (transl conf "several answers");
|
|
Output.print_sstring conf " ";
|
|
Output.print_sstring conf (transl conf "or");
|
|
Output.print_sstring conf " ";
|
|
Output.print_sstring conf (transl conf "incorrect request");
|
|
Hutil.trailer conf
|
|
|
|
let same_person conf =
|
|
let title _ =
|
|
Output.print_sstring conf (Utf8.capitalize_fst (transl conf "error"))
|
|
in
|
|
Hutil.rheader conf title;
|
|
Output.print_sstring conf
|
|
(Utf8.capitalize_fst (transl conf "it is the same person!"));
|
|
Hutil.trailer conf
|
|
|
|
let different_sexes conf base p1 p2 =
|
|
let title _ =
|
|
Output.print_sstring conf (Utf8.capitalize_fst (transl conf "error"))
|
|
in
|
|
Hutil.rheader conf title;
|
|
Output.print_sstring conf
|
|
(Utf8.capitalize_fst (transl conf "incompatible sexes"));
|
|
Output.print_sstring conf (transl conf ":");
|
|
Output.print_sstring conf {|<ul><li><a href="|};
|
|
Output.print_string conf (commd conf);
|
|
Output.print_string conf (acces conf base p1);
|
|
Output.print_sstring conf {|">|};
|
|
Output.print_string conf (Util.designation base p1);
|
|
Output.print_sstring conf {|</a></li><li>|};
|
|
Output.print_string conf (commd conf);
|
|
Output.print_string conf (acces conf base p2);
|
|
Output.print_sstring conf {|">|};
|
|
Output.print_string conf (Util.designation base p2);
|
|
Output.print_sstring conf "</li></ul>";
|
|
Hutil.trailer conf
|
|
|
|
let print_merged conf base wl p =
|
|
let title _ =
|
|
Output.print_sstring conf (Utf8.capitalize_fst (transl conf "merge done"))
|
|
in
|
|
Hutil.header conf title;
|
|
Output.print_sstring conf "<ul><li>";
|
|
Output.print_string conf (referenced_person_text conf base p);
|
|
Output.print_sstring conf "</li></ul>";
|
|
(match (p_getenv conf.env "m", p_getenv conf.env "ip") with
|
|
| Some "MRG_DUP_IND_Y_N", Some ip ->
|
|
let ip = iper_of_string ip in
|
|
let s1 =
|
|
match p_getenv conf.env "iexcl" with
|
|
| Some "" | None -> Adef.encoded ""
|
|
| Some s -> "¡=" ^<^ Mutil.encode s
|
|
in
|
|
let s2 =
|
|
match p_getenv conf.env "fexcl" with
|
|
| Some "" | None -> Adef.encoded ""
|
|
| Some s -> "&fexcl=" ^<^ Mutil.encode s
|
|
in
|
|
Output.print_sstring conf "<p>";
|
|
Output.print_sstring conf "<a href=";
|
|
Output.print_string conf (commd conf);
|
|
Output.print_sstring conf "m=MRG_DUP&ip=";
|
|
Output.print_string conf (string_of_iper ip |> Mutil.encode);
|
|
Output.print_string conf s1;
|
|
Output.print_string conf s2;
|
|
Output.print_sstring conf ">";
|
|
Output.print_sstring conf
|
|
(Utf8.capitalize_fst (transl conf "continue merging"));
|
|
Output.print_sstring conf "</a>";
|
|
(let p = poi base ip in
|
|
let s = gen_person_text conf base p in
|
|
Output.print_sstring conf "\n(";
|
|
Output.print_sstring conf
|
|
(Util.transl_a_of_b conf
|
|
(transl conf "possible duplications")
|
|
(reference conf base p s :> string)
|
|
(s :> string));
|
|
Output.print_sstring conf ")\n");
|
|
Output.print_sstring conf "</p>\n"
|
|
| _ -> ());
|
|
Update.print_warnings conf base wl;
|
|
Hutil.trailer conf
|
|
|
|
let print conf base =
|
|
let p1 =
|
|
match p_getenv conf.env "i" with
|
|
| Some i1 -> Some (poi base (iper_of_string i1))
|
|
| None -> None
|
|
in
|
|
let p2 =
|
|
match p_getenv conf.env "i2" with
|
|
| Some i2 -> Some (poi base (iper_of_string i2))
|
|
| None -> (
|
|
match (p_getenv conf.env "select", p_getenv conf.env "n") with
|
|
| (Some "input" | None), Some n -> (
|
|
let ipl = Gutil.person_ht_find_all base n in
|
|
match ipl with [ ip2 ] -> Some (poi base ip2) | _ -> None)
|
|
| Some x, (Some "" | None) -> Some (poi base (iper_of_string x))
|
|
| _ -> None)
|
|
in
|
|
match (p1, p2) with
|
|
| Some p1, Some p2 -> (
|
|
try
|
|
let ok, warnings =
|
|
merge conf base p1 p2 propose_merge_ind propose_merge_fam
|
|
in
|
|
if ok then print_merged conf base warnings p1
|
|
with
|
|
| Error_loop p -> error_loop conf base p
|
|
| Different_sexes (p1, p2) -> different_sexes conf base p1 p2
|
|
| Same_person -> same_person conf)
|
|
| _ -> not_found_or_incorrect conf
|
|
|
|
(* Undocumented feature... Kill someone's ancestors *)
|
|
|
|
let print_killed conf base p nb_ind nb_fam =
|
|
let title _ = Output.print_sstring conf "Ancestors killed" in
|
|
Hutil.header conf title;
|
|
Output.print_string conf (referenced_person_title_text conf base p);
|
|
Output.print_sstring conf "'s ancestors killed.<br>";
|
|
Output.print_sstring conf (string_of_int nb_ind);
|
|
Output.print_sstring conf " persons and ";
|
|
Output.print_sstring conf (string_of_int nb_fam);
|
|
Output.print_sstring conf " families deleted<p>";
|
|
Hutil.trailer conf
|
|
|
|
let print_kill_ancestors conf base =
|
|
match List.assoc_opt "can_kill_ancestors" conf.base_env with
|
|
| Some "yes" -> (
|
|
match find_person_in_env conf base "" with
|
|
| Some p ->
|
|
let nb_ind = ref 0 in
|
|
let nb_fam = ref 0 in
|
|
kill_ancestors conf base false p nb_ind nb_fam;
|
|
Util.commit_patches conf base;
|
|
let changed =
|
|
U_Kill_ancestors
|
|
(Util.string_gen_person base (gen_person_of_person p))
|
|
in
|
|
History.record conf base changed "ka";
|
|
print_killed conf base p !nb_ind !nb_fam
|
|
| None -> Hutil.incorrect_request conf)
|
|
| _ -> Hutil.incorrect_request conf
|