169 lines
6.2 KiB
OCaml
169 lines
6.2 KiB
OCaml
(* $Id: mergeFam.ml,v 5.13 2007-09-12 09:58:44 ddr Exp $ *)
|
|
(* Copyright (c) 1998-2007 INRIA *)
|
|
|
|
open Config
|
|
open Def
|
|
open Gwdb
|
|
open Util
|
|
|
|
let compatible_fevents fevt1 fevt2 = fevt1 = [] && fevt2 = []
|
|
|
|
let need_differences_selection conf base fam1 fam2 =
|
|
let need_selection proj =
|
|
let x1 = proj fam1 in
|
|
let x2 = proj fam2 in
|
|
x1 <> "" && x2 <> "" && x1 <> x2
|
|
in
|
|
need_selection (fun fam ->
|
|
match get_relation fam with
|
|
| Married -> "married"
|
|
| NotMarried -> "not married"
|
|
| Engaged -> "engaged"
|
|
| NoSexesCheckNotMarried -> "no sexes check"
|
|
| NoSexesCheckMarried -> "no sexes check married"
|
|
| NoMention -> "no mention"
|
|
| MarriageBann -> "marriage banns"
|
|
| MarriageContract -> "marriage contract"
|
|
| MarriageLicense -> "marriage license"
|
|
| Pacs -> "pacs"
|
|
| Residence -> "residence")
|
|
|| need_selection (fun fam ->
|
|
match Date.od_of_cdate (get_marriage fam) with
|
|
| None -> ""
|
|
| Some d -> (DateDisplay.string_of_ondate conf d :> string))
|
|
|| need_selection (fun fam -> sou base (get_marriage_place fam))
|
|
|| need_selection (fun fam ->
|
|
match get_divorce fam with
|
|
| NotDivorced -> "not divorced"
|
|
| Separated -> "separated"
|
|
| Divorced cod -> (
|
|
match Date.od_of_cdate cod with
|
|
| Some d -> (DateDisplay.string_of_ondate conf d :> string)
|
|
| None -> "divorced"))
|
|
|
|
let print_differences conf base branches (ifam1, fam1) (ifam2, fam2) =
|
|
let string_field (title : Adef.safe_string) (name : Adef.encoded_string) proj
|
|
=
|
|
let x1 : Adef.safe_string = proj fam1 in
|
|
let x2 : Adef.safe_string = proj fam2 in
|
|
if (x1 :> string) <> "" && (x2 :> string) <> "" && x1 <> x2 then (
|
|
Output.print_sstring conf "<h4>";
|
|
Output.print_string conf (Adef.safe_fn Utf8.capitalize_fst title);
|
|
Output.print_sstring conf
|
|
"</h4><ul><li><input type=\"radio\" class=\"form-control\" name=\"";
|
|
Output.print_string conf name;
|
|
Output.print_sstring conf "\" value=\"1\" checked>";
|
|
Output.print_string conf x1;
|
|
Output.print_sstring conf
|
|
"</li><li><input type=\"radio\" class=\"form-control\" name=\"";
|
|
Output.print_string conf name;
|
|
Output.print_sstring conf "\" value=\"2\">";
|
|
Output.print_string conf x2;
|
|
Output.print_sstring conf "</li></ul>")
|
|
in
|
|
Output.print_sstring conf "<form method=\"post\" action=\"";
|
|
Output.print_sstring conf conf.command;
|
|
Output.print_sstring conf "\">";
|
|
Util.hidden_env conf;
|
|
Util.hidden_input_s conf "m" "MRG_FAM_OK";
|
|
Util.hidden_input_s conf "i" (string_of_ifam ifam1);
|
|
Util.hidden_input_s conf "i2" (string_of_ifam ifam2);
|
|
(match p_getenv conf.env "ip" with
|
|
| Some ip -> Util.hidden_input conf "ip" (Mutil.encode ip)
|
|
| None -> ());
|
|
(let rec loop = function
|
|
| [ (ip1, ip2) ] ->
|
|
Util.hidden_input_s conf "ini1" (string_of_iper ip1);
|
|
Util.hidden_input_s conf "ini2" (string_of_iper ip2)
|
|
| _ :: branches -> loop branches
|
|
| _ -> ()
|
|
in
|
|
loop branches);
|
|
Output.print_sstring conf "<p>";
|
|
string_field
|
|
(transl_nth conf "relation/relations" 0 |> Adef.safe)
|
|
(Adef.encoded "relation")
|
|
(fun fam ->
|
|
Adef.safe @@ transl conf
|
|
@@
|
|
match get_relation fam with
|
|
| Married -> "married"
|
|
| NotMarried -> "not married"
|
|
| Engaged -> "engaged"
|
|
| NoSexesCheckNotMarried -> "no sexes check"
|
|
| NoSexesCheckMarried -> "married"
|
|
| NoMention -> "no mention"
|
|
| MarriageBann -> "marriage bann"
|
|
| MarriageContract -> "marriage contract"
|
|
| MarriageLicense -> "marriage licence"
|
|
| Pacs -> "PACS"
|
|
| Residence -> "residence");
|
|
string_field
|
|
(Util.translate_eval (transl_nth conf "marriage/marriages" 0) |> Adef.safe)
|
|
(Adef.encoded "marriage")
|
|
(fun fam ->
|
|
match Date.od_of_cdate (get_marriage fam) with
|
|
| None -> Adef.safe ""
|
|
| Some d -> DateDisplay.string_of_ondate conf d);
|
|
string_field
|
|
(Util.translate_eval (transl_nth conf "marriage/marriages" 0)
|
|
^ " / "
|
|
^ transl_nth conf "place/places" 0
|
|
|> Adef.safe)
|
|
(Adef.encoded "marriage_place")
|
|
(fun fam ->
|
|
(get_marriage_place fam |> sou base |> escape_html :> Adef.safe_string));
|
|
string_field
|
|
(transl conf "divorce" |> Adef.safe)
|
|
(Adef.encoded "divorce")
|
|
(fun fam ->
|
|
match get_divorce fam with
|
|
| NotDivorced -> transl conf "not divorced" |> Adef.safe
|
|
| Separated -> transl conf "separated" |> Adef.safe
|
|
| Divorced cod -> (
|
|
match Date.od_of_cdate cod with
|
|
| Some d ->
|
|
transl conf "divorced" ^<^ " "
|
|
^<^ DateDisplay.string_of_ondate conf d
|
|
| None -> transl conf "divorced" |> Adef.safe));
|
|
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 merge_fam1 conf base fam1 fam2 =
|
|
let title _ =
|
|
let s = transl_nth conf "family/families" 1 in
|
|
Output.print_sstring conf
|
|
(Utf8.capitalize_fst (transl_decline conf "merge" s))
|
|
in
|
|
Hutil.header conf title;
|
|
print_differences conf base [] fam1 fam2;
|
|
Hutil.trailer conf
|
|
|
|
let merge_fam conf base (ifam1, fam1) (ifam2, fam2) =
|
|
let cpl1 = foi base ifam1 in
|
|
let cpl2 = foi base ifam2 in
|
|
(* Vérifie que les deux couples sont identiques. Il est possible dans certains cas (couple de même sexe) que les personnes soient inversées dans l'union. *)
|
|
if
|
|
(get_father cpl1 = get_father cpl2 && get_mother cpl1 = get_mother cpl2)
|
|
|| (get_father cpl1 = get_mother cpl2 && get_mother cpl1 = get_father cpl2)
|
|
then
|
|
if
|
|
need_differences_selection conf base fam1 fam2
|
|
&& compatible_fevents (get_fevents fam1) (get_fevents fam2)
|
|
then merge_fam1 conf base (ifam1, fam1) (ifam2, fam2)
|
|
else MergeFamOk.print_merge conf base
|
|
else Hutil.incorrect_request conf
|
|
|
|
let print conf base =
|
|
match (p_getenv conf.env "i", p_getenv conf.env "i2") with
|
|
| Some f1, Some f2 ->
|
|
let ifam1 = ifam_of_string f1 in
|
|
let ifam2 = ifam_of_string f2 in
|
|
let fam1 = foi base ifam1 in
|
|
let fam2 = foi base ifam2 in
|
|
merge_fam conf base (ifam1, fam1) (ifam2, fam2)
|
|
| _ -> Hutil.incorrect_request conf
|