1507 lines
50 KiB
OCaml
1507 lines
50 KiB
OCaml
(* Copyright (c) 1998-2007 INRIA *)
|
||
|
||
open Config
|
||
open Def
|
||
open Gwdb
|
||
open Util
|
||
open Update_util
|
||
|
||
(* Liste des string dont on a supprimé un caractère. *)
|
||
(* Utilisé pour le message d'erreur lors de la validation. *)
|
||
let removed_string = ref []
|
||
let get_purged_fn_sn = Update_util.get_purged_fn_sn removed_string
|
||
let reconstitute_somebody = Update_util.reconstitute_somebody removed_string
|
||
|
||
let reconstitute_parent_or_child conf var default_surname =
|
||
let first_name = only_printable (getn conf var "fn") in
|
||
let surname =
|
||
let surname = only_printable (getn conf var "sn") in
|
||
if surname = "" then default_surname else surname
|
||
in
|
||
(* S'il y a des caractères interdits, on les supprime *)
|
||
let first_name, surname = get_purged_fn_sn first_name surname in
|
||
let occ = try int_of_string (getn conf var "occ") with Failure _ -> 0 in
|
||
let create_info =
|
||
let b = Update.reconstitute_date conf (var ^ "b") in
|
||
let bpl = getn conf (var ^ "b") "pl" in
|
||
let death =
|
||
match p_getenv conf.env (var ^ "d_yyyy") with
|
||
| Some "+" -> DeadDontKnowWhen
|
||
| Some ("-" | "=") -> NotDead
|
||
| Some _ | None -> DontKnowIfDead
|
||
in
|
||
let d = Update.reconstitute_date conf (var ^ "d") in
|
||
let dpl = getn conf (var ^ "d") "pl" in
|
||
let occupation = only_printable (getn conf var "occu") in
|
||
let public = getn conf (var ^ "b") "yyyy" = "p" in
|
||
{
|
||
ci_birth_date = b;
|
||
ci_birth_place = bpl;
|
||
ci_death = death;
|
||
ci_death_date = d;
|
||
ci_death_place = dpl;
|
||
ci_occupation = occupation;
|
||
ci_public = public;
|
||
}
|
||
in
|
||
let sex = getenv_sex conf var in
|
||
let create = getn_p conf var ~create_info sex in
|
||
(first_name, surname, occ, create, var)
|
||
|
||
let invert_children conf (c, children, ext) i =
|
||
let var = "inv_ch" ^ string_of_int (i + 1) in
|
||
match (p_getenv conf.env var, children) with
|
||
| Some "on", c1 :: children -> (c1, c :: children, true)
|
||
| _ -> (c, children, ext)
|
||
|
||
let insert_child conf (children, ext) i =
|
||
let var = "ins_ch" ^ string_of_int i in
|
||
match (p_getenv conf.env var, p_getint conf.env (var ^ "_n")) with
|
||
| _, Some n when n > 1 ->
|
||
let children =
|
||
let rec loop children n =
|
||
if n > 0 then
|
||
let new_child = ("", "", 0, Update.Create (Neuter, None), "") in
|
||
loop (new_child :: children) (n - 1)
|
||
else children
|
||
in
|
||
loop children n
|
||
in
|
||
(children, true)
|
||
| Some "on", _ ->
|
||
let new_child = ("", "", 0, Update.Create (Neuter, None), "") in
|
||
(new_child :: children, true)
|
||
| _ -> (children, ext)
|
||
|
||
let insert_parent conf (parents, ext) i =
|
||
let var = "ins_pa" ^ string_of_int i in
|
||
match (p_getenv conf.env var, p_getint conf.env (var ^ "_n")) with
|
||
| _, Some n when n > 1 ->
|
||
let parents =
|
||
let rec loop parents n =
|
||
if n > 0 then
|
||
let new_parent = ("", "", 0, Update.Create (Neuter, None), "") in
|
||
loop (new_parent :: parents) (n - 1)
|
||
else parents
|
||
in
|
||
loop parents n
|
||
in
|
||
(parents, true)
|
||
| Some "on", _ ->
|
||
let new_parent = ("", "", 0, Update.Create (Neuter, None), "") in
|
||
(new_parent :: parents, true)
|
||
| _ -> (parents, ext)
|
||
|
||
let reconstitute_insert_event conf ext cnt el =
|
||
let var = "ins_event" ^ string_of_int cnt in
|
||
let n =
|
||
match (p_getenv conf.env var, p_getint conf.env (var ^ "_n")) with
|
||
| _, Some n when n > 1 -> n
|
||
| Some "on", _ -> 1
|
||
| _ -> 0
|
||
in
|
||
if n > 0 then
|
||
let el =
|
||
let rec loop el n =
|
||
if n > 0 then
|
||
let e1 =
|
||
{
|
||
efam_name = Efam_Name "";
|
||
efam_date = Date.cdate_None;
|
||
efam_place = "";
|
||
efam_reason = "";
|
||
efam_note = "";
|
||
efam_src = "";
|
||
efam_witnesses = [||];
|
||
}
|
||
in
|
||
loop (e1 :: el) (n - 1)
|
||
else el
|
||
in
|
||
loop el n
|
||
in
|
||
(el, true)
|
||
else (el, ext)
|
||
|
||
let rec reconstitute_events conf ext cnt =
|
||
match get_nth conf "e_name" cnt with
|
||
| None -> ([], ext)
|
||
| Some efam_name ->
|
||
let efam_name =
|
||
match efam_name with
|
||
| "#marr" -> Efam_Marriage
|
||
| "#nmar" -> Efam_NoMarriage
|
||
| "#nmen" -> Efam_NoMention
|
||
| "#enga" -> Efam_Engage
|
||
| "#div" -> Efam_Divorce
|
||
| "#sep" -> Efam_Separated
|
||
| "#anul" -> Efam_Annulation
|
||
| "#marb" -> Efam_MarriageBann
|
||
| "#marc" -> Efam_MarriageContract
|
||
| "#marl" -> Efam_MarriageLicense
|
||
| "#pacs" -> Efam_PACS
|
||
| "#resi" -> Efam_Residence
|
||
| n -> Efam_Name (only_printable n)
|
||
in
|
||
let efam_date =
|
||
Update.reconstitute_date conf ("e_date" ^ string_of_int cnt)
|
||
in
|
||
let efam_place =
|
||
match get_nth conf "e_place" cnt with
|
||
| Some place -> only_printable place
|
||
| None -> ""
|
||
in
|
||
let efam_note =
|
||
match get_nth conf "e_note" cnt with
|
||
| Some note ->
|
||
only_printable_or_nl (Mutil.strip_all_trailing_spaces note)
|
||
| None -> ""
|
||
in
|
||
let efam_src =
|
||
match get_nth conf "e_src" cnt with
|
||
| Some src -> only_printable src
|
||
| None -> ""
|
||
in
|
||
let witnesses, ext =
|
||
let rec loop i ext =
|
||
let key = "e" ^ string_of_int cnt ^ "_witn" ^ string_of_int i in
|
||
match
|
||
try Some (reconstitute_somebody conf key) with Failure _ -> None
|
||
with
|
||
| None -> ([], ext)
|
||
| Some (fn, sn, occ, create, var) -> (
|
||
let witnesses, ext = loop (i + 1) ext in
|
||
let create = update_ci conf create key in
|
||
let c = (fn, sn, occ, create, var) in
|
||
let c =
|
||
match p_getenv conf.env (key ^ "_kind") with
|
||
| Some "godp" -> (c, Witness_GodParent)
|
||
| Some "offi" -> (c, Witness_CivilOfficer)
|
||
| Some "reli" -> (c, Witness_ReligiousOfficer)
|
||
| Some "info" -> (c, Witness_Informant)
|
||
| Some "atte" -> (c, Witness_Attending)
|
||
| Some "ment" -> (c, Witness_Mentioned)
|
||
| Some "othe" -> (c, Witness_Other)
|
||
| Some _ | None -> (c, Witness)
|
||
in
|
||
match
|
||
p_getenv conf.env
|
||
("e" ^ string_of_int cnt ^ "_ins_witn" ^ string_of_int i)
|
||
with
|
||
| Some "on" -> (
|
||
let ins_witn_n =
|
||
"e" ^ string_of_int cnt ^ "_ins_witn" ^ string_of_int i
|
||
^ "_n"
|
||
in
|
||
match p_getint conf.env ins_witn_n with
|
||
| Some n when n > 1 ->
|
||
let rec loop_witn n witnesses =
|
||
if n = 0 then (c :: witnesses, true)
|
||
else
|
||
let new_witn =
|
||
( ("", "", 0, Update.Create (Neuter, None), ""),
|
||
Witness )
|
||
in
|
||
let witnesses = new_witn :: witnesses in
|
||
loop_witn (n - 1) witnesses
|
||
in
|
||
loop_witn n witnesses
|
||
| Some _ | None ->
|
||
let new_witn =
|
||
(("", "", 0, Update.Create (Neuter, None), ""), Witness)
|
||
in
|
||
(c :: new_witn :: witnesses, true))
|
||
| Some _ | None -> (c :: witnesses, ext))
|
||
in
|
||
loop 1 ext
|
||
in
|
||
let witnesses, ext =
|
||
let evt_ins = "e" ^ string_of_int cnt ^ "_ins_witn0" in
|
||
match p_getenv conf.env evt_ins with
|
||
| Some "on" -> (
|
||
let ins_witn_n = "e" ^ string_of_int cnt ^ "_ins_witn0_n" in
|
||
match p_getint conf.env ins_witn_n with
|
||
| Some n when n > 1 ->
|
||
let rec loop_witn n witnesses =
|
||
if n = 0 then (witnesses, true)
|
||
else
|
||
let new_witn =
|
||
(("", "", 0, Update.Create (Neuter, None), ""), Witness)
|
||
in
|
||
let witnesses = new_witn :: witnesses in
|
||
loop_witn (n - 1) witnesses
|
||
in
|
||
loop_witn n witnesses
|
||
| Some _ | None ->
|
||
let new_witn =
|
||
(("", "", 0, Update.Create (Neuter, None), ""), Witness)
|
||
in
|
||
(new_witn :: witnesses, true))
|
||
| Some _ | None -> (witnesses, ext)
|
||
in
|
||
let e =
|
||
{
|
||
efam_name;
|
||
efam_date = Date.cdate_of_od efam_date;
|
||
efam_place;
|
||
efam_reason = "";
|
||
efam_note;
|
||
efam_src;
|
||
efam_witnesses = Array.of_list witnesses;
|
||
}
|
||
in
|
||
let el, ext = reconstitute_events conf ext (cnt + 1) in
|
||
let el, ext = reconstitute_insert_event conf ext cnt el in
|
||
(e :: el, ext)
|
||
|
||
(* S:
|
||
* why is marriage record transformed into a tuple?
|
||
*)
|
||
let reconstitute_from_fevents (nsck : bool) (empty_string : 'string)
|
||
(fevents : ('person, 'string) Def.gen_fam_event list) =
|
||
(* On tri les évènements pour être sûr. *)
|
||
let fevents =
|
||
Event.sort_events
|
||
(fun evt -> Event.Fevent evt.efam_name)
|
||
(fun evt -> evt.efam_date)
|
||
fevents
|
||
in
|
||
let found_marriage :
|
||
(Def.relation_kind
|
||
* Def.cdate
|
||
* 'string
|
||
* 'string
|
||
* 'string
|
||
* ('person * Def.witness_kind) array)
|
||
option
|
||
ref =
|
||
ref None
|
||
in
|
||
|
||
let found_divorce : Def.divorce option ref = ref None in
|
||
let mk_marr evt kind =
|
||
let e =
|
||
Some
|
||
( kind,
|
||
evt.efam_date,
|
||
evt.efam_place,
|
||
evt.efam_note,
|
||
evt.efam_src,
|
||
evt.efam_witnesses )
|
||
in
|
||
match !found_marriage with
|
||
| None -> found_marriage := e
|
||
| Some ((NoMention | Residence), _, _, _, _, _)
|
||
when kind <> NoMention && kind <> Residence ->
|
||
found_marriage := e
|
||
| Some (Married, _, _, _, _, _) when kind <> Married -> ()
|
||
| _ -> if kind = Married then found_marriage := e
|
||
in
|
||
let mk_div kind =
|
||
match !found_divorce with
|
||
| None -> found_divorce := Some kind
|
||
| Some _ -> ()
|
||
in
|
||
(* Marriage is more important than any other relation.
|
||
For other cases, latest event is the most important,
|
||
except for NotMention and Residence. *)
|
||
(* FIXME: For now, we ignore Annulation since it gives a wrong date
|
||
(relation on [annulation date] makes no sense) *)
|
||
let rec loop = function
|
||
| [] -> ()
|
||
| evt :: l -> (
|
||
match evt.efam_name with
|
||
| Efam_Engage ->
|
||
mk_marr evt Engaged;
|
||
loop l
|
||
| Efam_Marriage ->
|
||
mk_marr evt Married;
|
||
loop l
|
||
| Efam_MarriageContract ->
|
||
mk_marr evt MarriageContract;
|
||
loop l
|
||
| Efam_NoMention ->
|
||
mk_marr evt NoMention;
|
||
loop l
|
||
| Efam_MarriageBann ->
|
||
mk_marr evt MarriageBann;
|
||
loop l
|
||
| Efam_MarriageLicense ->
|
||
mk_marr evt MarriageLicense;
|
||
loop l
|
||
| Efam_PACS ->
|
||
mk_marr evt Pacs;
|
||
loop l
|
||
| Efam_Residence ->
|
||
mk_marr evt Residence;
|
||
loop l
|
||
| Efam_NoMarriage ->
|
||
mk_marr evt NotMarried;
|
||
loop l
|
||
| Efam_Divorce ->
|
||
mk_div (Divorced evt.efam_date);
|
||
loop l
|
||
| Efam_Separated ->
|
||
mk_div Separated;
|
||
loop l
|
||
| Efam_Annulation -> loop l
|
||
| Efam_Name _ -> loop l)
|
||
in
|
||
loop (List.rev fevents);
|
||
(* Il faut gérer le cas où l'on supprime délibérément l'évènement. *)
|
||
let marr, wit =
|
||
match !found_marriage with
|
||
| None ->
|
||
( (NoMention, Date.cdate_None, empty_string, empty_string, empty_string),
|
||
[||] )
|
||
| Some (kind, date, place, note, src, wit) ->
|
||
((kind, date, place, note, src), wit)
|
||
in
|
||
(* Parents de même sexe. *)
|
||
let marr =
|
||
if nsck then
|
||
let relation, date, place, note, src = marr in
|
||
let relation =
|
||
match relation with
|
||
| Married -> NoSexesCheckMarried
|
||
| ( NotMarried | Engaged | NoSexesCheckNotMarried | NoMention
|
||
| NoSexesCheckMarried | MarriageBann | MarriageContract
|
||
| MarriageLicense | Pacs | Residence ) as x ->
|
||
x
|
||
in
|
||
(relation, date, place, note, src)
|
||
else marr
|
||
in
|
||
let div = Option.value ~default:NotDivorced !found_divorce in
|
||
(marr, div, wit)
|
||
|
||
let reconstitute_family conf base nsck =
|
||
let events, ext = reconstitute_events conf false 1 in
|
||
let events, ext = reconstitute_insert_event conf ext 0 events in
|
||
let surname = getn conf "pa1" "sn" in
|
||
let children, ext =
|
||
let rec loop i ext =
|
||
match
|
||
try
|
||
Some
|
||
(reconstitute_parent_or_child conf ("ch" ^ string_of_int i) surname)
|
||
with Failure _ -> None
|
||
with
|
||
| Some c ->
|
||
let children, ext = loop (i + 1) ext in
|
||
let c, children, ext = invert_children conf (c, children, ext) i in
|
||
let children, ext = insert_child conf (children, ext) i in
|
||
(c :: children, ext)
|
||
| None -> ([], ext)
|
||
in
|
||
loop 1 ext
|
||
in
|
||
let children, ext = insert_child conf (children, ext) 0 in
|
||
let parents, ext =
|
||
let rec loop i ext =
|
||
match
|
||
try Some (reconstitute_parent_or_child conf ("pa" ^ string_of_int i) "")
|
||
with Failure _ -> None
|
||
with
|
||
| Some c ->
|
||
let parents, ext = loop (i + 1) ext in
|
||
let parents, ext = insert_parent conf (parents, ext) i in
|
||
(c :: parents, ext)
|
||
| None -> ([], ext)
|
||
in
|
||
loop 1 ext
|
||
in
|
||
let comment =
|
||
only_printable_or_nl (Mutil.strip_all_trailing_spaces (get conf "comment"))
|
||
in
|
||
let fsources = only_printable (get conf "src") in
|
||
let origin_file =
|
||
Option.value ~default:"" (p_getenv conf.env "origin_file")
|
||
in
|
||
let fam_index =
|
||
match p_getenv conf.env "i" with
|
||
| Some i -> Gwdb.ifam_of_string i
|
||
| None -> Gwdb.dummy_ifam
|
||
in
|
||
(* Mise à jour des évènements principaux. *)
|
||
(* Attention, dans le cas où fevent est vide, i.e. on a valider *)
|
||
(* avec un texte vide, par exemple lors de l'ajout d'une famille, *)
|
||
(* il faut ajouter un evenement no_mention. *)
|
||
let events =
|
||
if events = [] then
|
||
let evt =
|
||
{
|
||
efam_name = Efam_NoMention;
|
||
efam_date = Date.cdate_None;
|
||
efam_place = "";
|
||
efam_reason = "";
|
||
efam_note = "";
|
||
efam_src = "";
|
||
efam_witnesses = [||];
|
||
}
|
||
in
|
||
[ evt ]
|
||
else events
|
||
in
|
||
(* Attention, surtout pas les witnesses, parce que si on en créé un, *)
|
||
(* on le créé aussi dans witness et on ne pourra jamais valider. *)
|
||
let marr, div, _ =
|
||
(* FIXME: Use witnesses (and Array.map fst witnesses)
|
||
when witnesses will be added inplace *)
|
||
reconstitute_from_fevents nsck "" events
|
||
in
|
||
let relation, marriage, marriage_place, marriage_note, marriage_src = marr in
|
||
(* Si parents de même sex ... Pas de mode multi parent. *)
|
||
let relation =
|
||
match parents with
|
||
| [ father; mother ] -> (
|
||
let father_sex =
|
||
match father with
|
||
| _, _, _, Update.Create (sex, _), _ -> sex
|
||
| f, s, o, Update.Link, _ -> (
|
||
match person_of_key base f s o with
|
||
| Some ip -> get_sex (poi base ip)
|
||
| _ -> Neuter)
|
||
in
|
||
let mother_sex =
|
||
match mother with
|
||
| _, _, _, Update.Create (sex, _), _ -> sex
|
||
| f, s, o, Update.Link, _ -> (
|
||
match person_of_key base f s o with
|
||
| Some ip -> get_sex (poi base ip)
|
||
| _ -> Neuter)
|
||
in
|
||
match (father_sex, mother_sex) with
|
||
| Male, Male | Female, Female -> (
|
||
match relation with
|
||
| Married -> NoSexesCheckMarried
|
||
| _ -> NoSexesCheckNotMarried)
|
||
| _ -> relation)
|
||
| _ -> relation
|
||
in
|
||
let divorce = div in
|
||
let fam =
|
||
{
|
||
marriage;
|
||
marriage_place;
|
||
marriage_note;
|
||
marriage_src;
|
||
witnesses = [||];
|
||
relation;
|
||
divorce;
|
||
fevents = events;
|
||
comment;
|
||
origin_file;
|
||
fsources;
|
||
fam_index;
|
||
}
|
||
and cpl = Futil.parent conf.multi_parents (Array.of_list parents)
|
||
and des = { children = Array.of_list children } in
|
||
(fam, cpl, des, ext)
|
||
|
||
let strip_events fevents =
|
||
let strip_array_witness pl =
|
||
Array.of_list
|
||
@@ Array.fold_right
|
||
(fun (((f, _, _, _, _), _) as p) pl -> if f = "" then pl else p :: pl)
|
||
pl []
|
||
in
|
||
List.fold_right
|
||
(fun e accu ->
|
||
let has_name =
|
||
match e.efam_name with Efam_Name s -> s <> "" | _ -> true
|
||
in
|
||
if has_name then
|
||
let witnesses = strip_array_witness e.efam_witnesses in
|
||
{ e with efam_witnesses = witnesses } :: accu
|
||
else accu)
|
||
fevents []
|
||
|
||
let strip_array_persons pl =
|
||
Array.of_list
|
||
@@ Array.fold_right
|
||
(fun ((f, _, _, _, _) as p) pl -> if f = "" then pl else p :: pl)
|
||
pl []
|
||
|
||
let error_family conf err =
|
||
Update.prerr conf err @@ fun () ->
|
||
(err |> Update.string_of_error conf : Adef.safe_string :> string)
|
||
|> Utf8.capitalize_fst |> Output.print_sstring conf;
|
||
Output.print_sstring conf "\n";
|
||
Update.print_return conf
|
||
|
||
let check_parents conf cpl =
|
||
let check get i =
|
||
let fn, sn, _, _, _ = get cpl in
|
||
if fn = "" then
|
||
if sn <> "" then
|
||
Some
|
||
(Update.UERR_missing_first_name
|
||
(transl_nth conf "father/mother" i |> Adef.safe))
|
||
else None
|
||
else if sn = "" then
|
||
Some
|
||
(Update.UERR_missing_surname
|
||
(transl_nth conf "father/mother" i |> Adef.safe))
|
||
else None
|
||
in
|
||
match check Gutil.father 0 with
|
||
| Some _ as err -> err
|
||
| None -> check Gutil.mother 1
|
||
|
||
let check_family conf fam cpl :
|
||
Update.update_error option * Update.update_error option =
|
||
let err_parents = check_parents conf cpl in
|
||
let err_fevent_witness =
|
||
Update.check_missing_witnesses_names conf
|
||
(fun e -> e.efam_witnesses)
|
||
fam.fevents
|
||
in
|
||
(err_fevent_witness, err_parents)
|
||
|
||
let strip_family fam des =
|
||
let fam =
|
||
{
|
||
fam with
|
||
witnesses = strip_array_persons fam.witnesses;
|
||
fevents = strip_events fam.fevents;
|
||
}
|
||
in
|
||
let des = { children = strip_array_persons des.children } in
|
||
(fam, des)
|
||
|
||
let print_err_parents conf base p =
|
||
let err = Update.UERR_already_has_parents (base, p) in
|
||
Update.prerr conf err @@ fun () ->
|
||
Output.print_sstring conf "\n";
|
||
Output.print_string conf (Update.string_of_error conf err);
|
||
Output.print_sstring conf "<p><ul><li>";
|
||
Output.print_sstring conf
|
||
(Utf8.capitalize_fst (transl conf "first free number"));
|
||
Output.print_sstring conf (Util.transl conf ":");
|
||
Output.print_sstring conf @@ string_of_int
|
||
@@ Gutil.find_free_occ base (p_first_name base p) (p_surname base p);
|
||
Output.print_sstring conf "</li></ul>";
|
||
Update.print_return conf
|
||
|
||
let print_err_sex conf base p =
|
||
let err = Update.UERR_sex_incoherent (base, p) in
|
||
Update.prerr conf err @@ fun () ->
|
||
Output.print_string conf (Update.string_of_error conf err);
|
||
Update.print_return conf
|
||
|
||
let print_err conf =
|
||
let err =
|
||
Update.UERR (transl conf "error" |> Utf8.capitalize_fst |> Adef.safe)
|
||
in
|
||
Update.prerr conf err @@ fun () -> Update.print_return conf
|
||
|
||
let print_error_disconnected conf =
|
||
let err =
|
||
Update.UERR
|
||
(transl conf "msg error disconnected" |> Utf8.capitalize_fst |> Adef.safe)
|
||
in
|
||
Update.prerr conf err @@ fun () ->
|
||
Hutil.print_link_to_welcome conf true;
|
||
Output.print_string conf (Update.string_of_error conf err)
|
||
|
||
let family_exclude pfams efam =
|
||
let pfaml =
|
||
Array.fold_right
|
||
(fun fam faml -> if fam = efam then faml else fam :: faml)
|
||
pfams []
|
||
in
|
||
Array.of_list pfaml
|
||
|
||
let infer_origin_file_from_other_marriages base ifam ip =
|
||
let u = poi base ip in
|
||
let ufams = get_family u in
|
||
let rec loop i =
|
||
if i = Array.length ufams then None
|
||
else if ufams.(i) = ifam then loop (i + 1)
|
||
else
|
||
let r = get_origin_file (foi base ufams.(i)) in
|
||
if sou base r <> "" then Some r else loop (i + 1)
|
||
in
|
||
loop 0
|
||
|
||
let infer_origin_file conf base ifam ncpl ndes =
|
||
let r = infer_origin_file_from_other_marriages base ifam (Adef.father ncpl) in
|
||
let r =
|
||
if r = None then
|
||
infer_origin_file_from_other_marriages base ifam (Adef.mother ncpl)
|
||
else r
|
||
in
|
||
let r =
|
||
match r with
|
||
| Some r -> r
|
||
| None -> (
|
||
let afath = poi base (Adef.father ncpl) in
|
||
let amoth = poi base (Adef.mother ncpl) in
|
||
match (get_parents afath, get_parents amoth) with
|
||
| Some if1, _ when sou base (get_origin_file (foi base if1)) <> "" ->
|
||
get_origin_file (foi base if1)
|
||
| _, Some if2 when sou base (get_origin_file (foi base if2)) <> "" ->
|
||
get_origin_file (foi base if2)
|
||
| _ ->
|
||
let rec loop i =
|
||
if i = Array.length ndes.children then Gwdb.insert_string base ""
|
||
else
|
||
let cifams = get_family (poi base ndes.children.(i)) in
|
||
if Array.length cifams = 0 then loop (i + 1)
|
||
else if sou base (get_origin_file (foi base cifams.(0))) <> ""
|
||
then get_origin_file (foi base cifams.(0))
|
||
else loop (i + 1)
|
||
in
|
||
loop 0)
|
||
in
|
||
let no_dec =
|
||
try List.assoc "propose_add_family" conf.base_env = "no"
|
||
with Not_found -> false
|
||
in
|
||
if no_dec && sou base r = "" then print_error_disconnected conf else r
|
||
|
||
(* TODO EVENT put this in Event *)
|
||
let fwitnesses_of fevents =
|
||
List.fold_left
|
||
(fun ipl e ->
|
||
Array.fold_left (fun ipl (ip, _) -> ip :: ipl) ipl e.efam_witnesses)
|
||
[] fevents
|
||
|
||
(* Lorsqu'on ajout naissance décès par exemple en créant une personne. *)
|
||
let patch_person_with_pevents base ip =
|
||
let p = poi base ip |> gen_person_of_person in
|
||
let evt ~name ?(date = Date.cdate_None) ~place ~src ~note () =
|
||
{
|
||
epers_name = name;
|
||
epers_date = date;
|
||
epers_place = place;
|
||
epers_reason = Gwdb.empty_string;
|
||
epers_note = note;
|
||
epers_src = src;
|
||
epers_witnesses = [||];
|
||
}
|
||
(* TODO why empty witnesses *)
|
||
in
|
||
let evt_birth =
|
||
let evt ?date () =
|
||
let name = Epers_Birth in
|
||
let place = p.birth_place in
|
||
let note = p.birth_note in
|
||
let src = p.birth_src in
|
||
Some (evt ~name ?date ~place ~note ~src ())
|
||
in
|
||
if Option.is_some (Date.od_of_cdate p.birth) then evt ~date:p.birth ()
|
||
else if sou base p.birth_place = "" then None
|
||
else evt ()
|
||
in
|
||
let evt_baptism =
|
||
let evt ?date () =
|
||
let name = Epers_Baptism in
|
||
let place = p.baptism_place in
|
||
let note = p.baptism_note in
|
||
let src = p.baptism_src in
|
||
Some (evt ~name ?date ~place ~note ~src ())
|
||
in
|
||
if Option.is_some (Date.od_of_cdate p.baptism) then evt ~date:p.baptism ()
|
||
else if sou base p.baptism_place = "" then None
|
||
else evt ()
|
||
in
|
||
let evt_death =
|
||
let evt ?date () =
|
||
let name = Epers_Death in
|
||
let place = p.death_place in
|
||
let note = p.death_note in
|
||
let src = p.death_src in
|
||
Some (evt ~name ?date ~place ~note ~src ())
|
||
in
|
||
match Date.date_of_death p.death with
|
||
| Some cd ->
|
||
let date = Date.cdate_of_od (Some cd) in
|
||
evt ~date ()
|
||
| None -> if sou base p.death_place = "" then None else evt ()
|
||
in
|
||
(* Attention, on prend aussi les autres évènements sinon, *)
|
||
(* on va tout effacer et ne garder que naissance et décès. *)
|
||
let pevents =
|
||
let found_birth = ref false in
|
||
let found_baptism = ref false in
|
||
let found_death = ref false in
|
||
let replace_witnesses event found new_event =
|
||
(* Si il y avait des témoins, on les remets en place. *)
|
||
if !found then event
|
||
else
|
||
match new_event with
|
||
| None -> event
|
||
| Some new_event ->
|
||
found := true;
|
||
{ new_event with epers_witnesses = event.epers_witnesses }
|
||
in
|
||
let l =
|
||
List.map
|
||
(fun evt ->
|
||
match evt.epers_name with
|
||
| Epers_Birth -> replace_witnesses evt found_birth evt_birth
|
||
| Epers_Baptism -> replace_witnesses evt found_baptism evt_baptism
|
||
| Epers_Death -> replace_witnesses evt found_death evt_death
|
||
| _other -> evt)
|
||
p.pevents
|
||
in
|
||
(* add default birth|baptism|death event if it was not found *)
|
||
let complete found event_opt l =
|
||
if found then l
|
||
else match event_opt with None -> l | Some evt -> evt :: l
|
||
in
|
||
complete !found_birth evt_birth l
|
||
|> complete !found_baptism evt_baptism
|
||
|> complete !found_death evt_death
|
||
in
|
||
let p = { p with pevents } in
|
||
patch_person base p.key_index p
|
||
|
||
let patch_parent_with_pevents base cpl =
|
||
Array.iter (patch_person_with_pevents base) (Adef.parent_array cpl)
|
||
|
||
let patch_children_with_pevents base des =
|
||
Array.iter (patch_person_with_pevents base) des.children
|
||
|
||
(* On met à jour les témoins maintenant. *)
|
||
let update_family_with_fevents conf base fam =
|
||
let marr, div, witnesses =
|
||
reconstitute_from_fevents
|
||
(p_getenv conf.env "nsck" = Some "on")
|
||
(Gwdb.insert_string base "")
|
||
fam.fevents
|
||
in
|
||
let relation, marriage, marriage_place, marriage_note, marriage_src = marr in
|
||
let divorce = div in
|
||
let witnesses = Array.map fst witnesses in
|
||
{
|
||
fam with
|
||
marriage;
|
||
marriage_place;
|
||
marriage_note;
|
||
marriage_src;
|
||
relation;
|
||
divorce;
|
||
witnesses;
|
||
}
|
||
|
||
let aux_effective_mod conf base nsck sfam scpl sdes fi origin_file =
|
||
let created_p = ref [] in
|
||
let psrc =
|
||
match p_getenv conf.env "psrc" with Some s -> String.trim s | None -> ""
|
||
in
|
||
let ncpl =
|
||
Futil.map_couple_p conf.multi_parents
|
||
(Update.insert_person conf base psrc created_p)
|
||
scpl
|
||
in
|
||
let nfam =
|
||
Futil.map_family_ps
|
||
(Update.insert_person conf base psrc created_p)
|
||
(fun f -> f)
|
||
(Gwdb.insert_string base) sfam
|
||
in
|
||
let ndes =
|
||
Futil.map_descend_p (Update.insert_person conf base psrc created_p) sdes
|
||
in
|
||
let nfath_p = poi base (Adef.father ncpl) in
|
||
let nmoth_p = poi base (Adef.mother ncpl) in
|
||
let nfam = update_family_with_fevents conf base nfam in
|
||
let nfam =
|
||
(* En mode api, on gère directement la relation de même sexe. *)
|
||
if conf.api_mode then { nfam with relation = sfam.relation } else nfam
|
||
in
|
||
if not nsck then (
|
||
let exp sex p =
|
||
let s = get_sex p in
|
||
if s = Neuter then
|
||
let p = { (gen_person_of_person p) with sex } in
|
||
patch_person base p.key_index p
|
||
else if s <> sex then print_err_sex conf base p
|
||
in
|
||
exp Male nfath_p;
|
||
exp Female nmoth_p);
|
||
if Adef.father ncpl = Adef.mother ncpl then print_err conf;
|
||
let origin_file = origin_file nfam ncpl ndes in
|
||
let nfam = { nfam with origin_file; fam_index = fi } in
|
||
patch_family base fi nfam;
|
||
patch_couple base fi ncpl;
|
||
patch_descend base fi ndes;
|
||
(nfath_p, nmoth_p, nfam, ncpl, ndes)
|
||
|
||
let effective_mod conf base nsck sfam scpl sdes =
|
||
let fi = sfam.fam_index in
|
||
let oorigin, owitnesses, ofevents =
|
||
let ofam = foi base fi in
|
||
(get_origin_file ofam, get_witnesses ofam, get_fevents ofam)
|
||
in
|
||
let oarr, ofather, omother =
|
||
let ocpl = foi base fi in
|
||
(get_parent_array ocpl, get_father ocpl, get_mother ocpl)
|
||
in
|
||
let ochildren = get_children (foi base fi) in
|
||
let origin_file nfam ncpl ndes =
|
||
if sfam.origin_file = "" then
|
||
if sou base oorigin <> "" then oorigin
|
||
else infer_origin_file conf base fi ncpl ndes
|
||
else nfam.origin_file
|
||
in
|
||
let _, _, nfam, ncpl, ndes =
|
||
aux_effective_mod conf base nsck sfam scpl sdes fi origin_file
|
||
in
|
||
let narr = Adef.parent_array ncpl in
|
||
for i = 0 to Array.length oarr - 1 do
|
||
if not (Array.mem oarr.(i) narr) then
|
||
let ou = poi base oarr.(i) in
|
||
let ou = { family = family_exclude (get_family ou) fi } in
|
||
patch_union base oarr.(i) ou
|
||
done;
|
||
for i = 0 to Array.length narr - 1 do
|
||
if not (Array.mem narr.(i) oarr) then
|
||
let nu = poi base narr.(i) in
|
||
let nu = { family = Array.append (get_family nu) [| fi |] } in
|
||
patch_union base narr.(i) nu
|
||
done;
|
||
let cache = Hashtbl.create 101 in
|
||
let find_asc ip =
|
||
try Hashtbl.find cache ip
|
||
with Not_found ->
|
||
let a = poi base ip in
|
||
let a = { parents = get_parents a; consang = get_consang a } in
|
||
Hashtbl.add cache ip a;
|
||
a
|
||
in
|
||
let same_parents = Adef.father ncpl = ofather && Adef.mother ncpl = omother in
|
||
Array.iter
|
||
(fun ip ->
|
||
let a = find_asc ip in
|
||
let a =
|
||
{
|
||
parents = None;
|
||
consang =
|
||
(if not (Array.mem ip ndes.children) then Adef.fix (-1)
|
||
else a.consang);
|
||
}
|
||
in
|
||
Hashtbl.replace cache ip a)
|
||
ochildren;
|
||
Array.iter
|
||
(fun ip ->
|
||
let a = find_asc ip in
|
||
match a.parents with
|
||
| Some _ -> print_err_parents conf base (poi base ip)
|
||
| None ->
|
||
let a =
|
||
{
|
||
parents = Some fi;
|
||
consang =
|
||
(if (not (Array.mem ip ochildren)) || not same_parents then
|
||
Adef.fix (-1)
|
||
else a.consang);
|
||
}
|
||
in
|
||
Hashtbl.replace cache ip a)
|
||
ndes.children;
|
||
Array.iter
|
||
(fun ip ->
|
||
if not (Array.mem ip ndes.children) then
|
||
patch_ascend base ip (find_asc ip))
|
||
ochildren;
|
||
Array.iter
|
||
(fun ip ->
|
||
if (not (Array.mem ip ochildren)) || not same_parents then
|
||
patch_ascend base ip (find_asc ip))
|
||
ndes.children;
|
||
let ol =
|
||
Array.fold_right (fun x acc -> x :: acc) owitnesses (fwitnesses_of ofevents)
|
||
in
|
||
let nl =
|
||
Array.fold_right
|
||
(fun x acc -> x :: acc)
|
||
nfam.witnesses
|
||
(fwitnesses_of nfam.fevents)
|
||
in
|
||
let pi = Adef.father ncpl in
|
||
Update.update_related_pointers base pi ol nl;
|
||
(fi, nfam, ncpl, ndes)
|
||
|
||
let effective_add conf base nsck sfam scpl sdes =
|
||
let fi = insert_family base (no_family dummy_ifam) no_couple no_descend in
|
||
let origin_file _nfam ncpl ndes = infer_origin_file conf base fi ncpl ndes in
|
||
let nfath_p, nmoth_p, nfam, ncpl, ndes =
|
||
aux_effective_mod conf base nsck sfam scpl sdes fi origin_file
|
||
in
|
||
let nfath_u = { family = Array.append (get_family nfath_p) [| fi |] } in
|
||
let nmoth_u = { family = Array.append (get_family nmoth_p) [| fi |] } in
|
||
patch_union base (Adef.father ncpl) nfath_u;
|
||
patch_union base (Adef.mother ncpl) nmoth_u;
|
||
Array.iter
|
||
(fun ip ->
|
||
let p = poi base ip in
|
||
match get_parents p with
|
||
| Some _ -> print_err_parents conf base p
|
||
| None ->
|
||
let a = { parents = Some fi; consang = Adef.fix (-1) } in
|
||
patch_ascend base (get_iper p) a)
|
||
ndes.children;
|
||
let nl_witnesses = Array.to_list nfam.witnesses in
|
||
let nl_fevents = fwitnesses_of nfam.fevents in
|
||
let nl = List.append nl_witnesses nl_fevents in
|
||
Update.update_related_pointers base (Adef.father ncpl) [] nl;
|
||
(fi, nfam, ncpl, ndes)
|
||
|
||
let effective_inv conf base ip u ifam =
|
||
let rec loop = function
|
||
| ifam1 :: ifam2 :: ifaml ->
|
||
if ifam2 = ifam then ifam2 :: ifam1 :: ifaml
|
||
else ifam1 :: loop (ifam2 :: ifaml)
|
||
| _ ->
|
||
Hutil.incorrect_request conf;
|
||
raise
|
||
@@ Update.ModErr
|
||
(Update.UERR (__FILE__ ^ " " ^ string_of_int __LINE__ |> Adef.safe))
|
||
in
|
||
let u = { family = Array.of_list (loop (Array.to_list (get_family u))) } in
|
||
patch_union base ip u
|
||
|
||
(* ************************************************************************ *)
|
||
(* [Fonc] effective_chg_order : base -> iper -> person -> ifam -> int -> unit *)
|
||
|
||
(* ************************************************************************ *)
|
||
|
||
(** [Description] : Modifie l'ordre de la famille en positionnant la famille
|
||
ifam à la position n. Exemple : [f1 f2 f3 f4] f1 3 => [f2 f3 f1 f4].
|
||
[Args] :
|
||
- base : base de donnée
|
||
- ip : iper
|
||
- u : person
|
||
- ifam : famille à changer de place
|
||
- n : nouvelle position de la famille
|
||
[Retour] : Néant
|
||
[Rem] : Non exporté en clair hors de ce module. *)
|
||
let effective_chg_order base ip u ifam n =
|
||
let fam = UpdateFam.change_order u ifam n in
|
||
let u = { family = Array.of_list fam } in
|
||
patch_union base ip u
|
||
|
||
let effective_del conf base ip fam =
|
||
let ifam = get_ifam fam in
|
||
delete_family base ifam;
|
||
let changed =
|
||
let gen_p =
|
||
let p =
|
||
if ip = get_mother fam then poi base (get_mother fam)
|
||
else poi base (get_father fam)
|
||
in
|
||
Util.string_gen_person base (gen_person_of_person p)
|
||
in
|
||
let gen_fam = Util.string_gen_family base (gen_family_of_family fam) in
|
||
U_Delete_family (gen_p, gen_fam)
|
||
in
|
||
History.record conf base changed "df"
|
||
|
||
let is_a_link = function _, _, _, Update.Link, _ -> true | _ -> false
|
||
|
||
let is_created_or_already_there ochil_arr nchil schil =
|
||
(not (is_a_link schil)) || Array.mem nchil ochil_arr
|
||
|
||
(* need_check_noloop: optimization
|
||
The no-loop check being a big work on large databases, this
|
||
optimization tests if this is really necessary or not. It is not
|
||
necessary if:
|
||
1/ either all parents are created,
|
||
2/ or all children are created,
|
||
3/ or the new family have the same parents than the old one *and*
|
||
all linked (not created) new children were already children.
|
||
*)
|
||
(* Replaced && by || to do more checks. *)
|
||
(* Improvement : check the name on the parents/children if they linked *)
|
||
|
||
let need_check_noloop (scpl, sdes, onfs) =
|
||
if
|
||
Array.exists is_a_link (Gutil.parent_array scpl)
|
||
|| Array.exists is_a_link sdes.children
|
||
then
|
||
match onfs with
|
||
| Some ((opar, ochil), (npar, nchil)) ->
|
||
(not
|
||
(Mutil.array_forall2
|
||
(is_created_or_already_there opar)
|
||
npar (Gutil.parent_array scpl)))
|
||
|| not
|
||
(Mutil.array_forall2
|
||
(is_created_or_already_there ochil)
|
||
nchil sdes.children)
|
||
| None -> true
|
||
else false
|
||
|
||
let all_checks_family conf base ifam gen_fam cpl des scdo =
|
||
let wl = ref [] in
|
||
let ml = ref [] in
|
||
let error = Update.def_error conf base in
|
||
let warning w = wl := w :: !wl in
|
||
let misc m = ml := m :: !ml in
|
||
if need_check_noloop scdo then
|
||
Consang.check_noloop_for_person_list base error
|
||
(Array.to_list (Adef.parent_array cpl));
|
||
let fam = family_of_gen_family base (gen_fam, cpl, des) in
|
||
CheckItem.family base warning ifam fam;
|
||
CheckItem.check_other_fields base misc ifam fam;
|
||
let wl, ml = (List.sort_uniq compare !wl, List.sort_uniq compare !ml) in
|
||
List.iter
|
||
(function
|
||
| ChangedOrderOfMarriages (p, _, after) ->
|
||
patch_union base (get_iper p) { family = after }
|
||
| ChangedOrderOfFamilyEvents (ifam, _, after) ->
|
||
patch_family base ifam { gen_fam with fevents = after }
|
||
| _ -> ())
|
||
wl;
|
||
(wl, ml)
|
||
|
||
let print_family conf base (wl, ml) cpl des =
|
||
let rdsrc =
|
||
match p_getenv conf.env "rdsrc" with
|
||
| Some "on" -> p_getenv conf.env "src"
|
||
| Some _ | None -> p_getenv conf.env "dsrc"
|
||
in
|
||
(match rdsrc with
|
||
| Some x ->
|
||
conf.henv <- List.remove_assoc "dsrc" conf.henv;
|
||
if x <> "" then conf.henv <- ("dsrc", Mutil.encode x) :: conf.henv
|
||
| None -> ());
|
||
Output.print_sstring conf "<ul>\n";
|
||
Output.print_sstring conf "<li>";
|
||
Output.print_string conf
|
||
(referenced_person_text conf base (poi base (Adef.father cpl)));
|
||
Output.print_sstring conf "</li>";
|
||
Output.print_sstring conf "\n";
|
||
Output.print_sstring conf "<li>";
|
||
Output.print_string conf
|
||
(referenced_person_text conf base (poi base (Adef.mother cpl)));
|
||
Output.print_sstring conf "</li>";
|
||
Output.print_sstring conf "</ul>\n";
|
||
if des.children <> [||] then (
|
||
Output.print_sstring conf "<ul>\n";
|
||
Array.iter
|
||
(fun ip ->
|
||
Output.print_sstring conf "<li>";
|
||
Output.print_string conf
|
||
(referenced_person_text conf base (poi base ip));
|
||
Output.print_sstring conf "</li>")
|
||
des.children;
|
||
Output.print_sstring conf "</ul>\n");
|
||
Update.print_warnings_and_miscs conf base wl ml
|
||
|
||
let print_title conf fmt _ =
|
||
Output.print_sstring conf (Utf8.capitalize_fst (transl conf fmt))
|
||
|
||
let print_mod_ok conf base (wl, ml) cpl des =
|
||
Hutil.header conf @@ print_title conf "family modified";
|
||
(* Si on a supprim<69> des caract<63>res interdits *)
|
||
if List.length !removed_string > 0 then (
|
||
Output.print_sstring conf "<h3 class=\"error\">";
|
||
Output.printf conf
|
||
(fcapitale (ftransl conf "%s forbidden char"))
|
||
(List.fold_left
|
||
(fun acc c -> acc ^ "'" ^ Char.escaped c ^ "' ")
|
||
" " Name.forbidden_char);
|
||
Output.print_sstring conf "</h3>\n";
|
||
List.iter (Output.printf conf "<p>%s</p>") !removed_string);
|
||
print_family conf base (wl, ml) cpl des;
|
||
Hutil.trailer conf
|
||
|
||
let print_change_event_order_ok conf base (wl, ml) cpl des =
|
||
Hutil.header conf @@ print_title conf "family modified";
|
||
print_family conf base (wl, ml) cpl des;
|
||
Hutil.trailer conf
|
||
|
||
let print_add_ok conf base (wl, ml) cpl des =
|
||
Hutil.header conf @@ print_title conf "family added";
|
||
(* Si on a supprim<69> des caract<63>res interdits *)
|
||
if List.length !removed_string > 0 then (
|
||
Output.printf conf "<h2 class=\"error\">%s</h2>\n"
|
||
(Utf8.capitalize_fst (transl conf "forbidden char"));
|
||
List.iter (Output.printf conf "<p>%s</p>") !removed_string);
|
||
print_family conf base (wl, ml) cpl des;
|
||
Hutil.trailer conf
|
||
|
||
let print_del_ok conf base wl =
|
||
Hutil.header conf @@ print_title conf "family deleted";
|
||
(match p_getenv conf.env "ip" with
|
||
| Some i ->
|
||
let p = poi base (iper_of_string i) in
|
||
Output.print_sstring conf "<ul><li>";
|
||
Output.print_string conf
|
||
(reference conf base p (gen_person_text conf base p));
|
||
Output.print_sstring conf "\n</ul>"
|
||
| None -> ());
|
||
Update.print_warnings conf base wl;
|
||
Hutil.trailer conf
|
||
|
||
let print_del conf base =
|
||
match p_getenv conf.env "i" with
|
||
| Some i ->
|
||
let ifam = ifam_of_string i in
|
||
let fam = foi base ifam in
|
||
let ip =
|
||
match p_getenv conf.env "ip" with
|
||
| Some i when get_mother fam = iper_of_string i -> get_mother fam
|
||
| Some _ | None -> get_father fam
|
||
in
|
||
effective_del conf base ip fam;
|
||
Util.commit_patches conf base;
|
||
print_del_ok conf base []
|
||
| None -> Hutil.incorrect_request conf
|
||
|
||
let print_inv_ok conf base p =
|
||
Hutil.header conf @@ print_title conf "inversion done";
|
||
Output.print_sstring conf "\n";
|
||
Output.print_string conf (referenced_person_text conf base p);
|
||
Output.print_sstring conf "\n";
|
||
Hutil.trailer conf
|
||
|
||
let get_create (_, _, _, create, _) = create
|
||
|
||
let forbidden_disconnected conf scpl sdes =
|
||
let no_dec =
|
||
try List.assoc "propose_add_family" conf.base_env = "no"
|
||
with Not_found -> false
|
||
in
|
||
if no_dec then
|
||
if
|
||
get_create (Gutil.father scpl) = Update.Link
|
||
|| get_create (Gutil.mother scpl) = Update.Link
|
||
then false
|
||
else Array.for_all (fun p -> get_create p <> Update.Link) sdes.children
|
||
else false
|
||
|
||
let print_add o_conf base =
|
||
(* Attention ! On pense à remettre les compteurs à *)
|
||
(* zéro pour la détection des caractères interdits *)
|
||
let () = removed_string := [] in
|
||
let conf = Update.update_conf o_conf in
|
||
let nsck = p_getenv conf.env "nsck" = Some "on" in
|
||
let sfam, scpl, sdes, ext = reconstitute_family conf base nsck in
|
||
let redisp = Option.is_some (p_getenv conf.env "return") in
|
||
let digest =
|
||
match p_getenv conf.env "ip" with
|
||
| Some ip ->
|
||
string_of_int (Array.length (get_family (poi base (iper_of_string ip))))
|
||
| None -> ""
|
||
in
|
||
let sdigest = get conf "digest" in
|
||
if digest <> "" && sdigest <> "" && digest <> sdigest then
|
||
Update.error_digest conf
|
||
else if ext || redisp then
|
||
UpdateFam.print_update_fam conf base (sfam, scpl, sdes) ""
|
||
else if forbidden_disconnected conf scpl sdes then
|
||
print_error_disconnected conf
|
||
else
|
||
match check_family conf sfam scpl with
|
||
| Some err, _ | _, Some err -> error_family conf err
|
||
| None, None ->
|
||
let sfam, sdes = strip_family sfam sdes in
|
||
let nsck = p_getenv conf.env "nsck" = Some "on" in
|
||
let ifam, fam, cpl, des = effective_add conf base nsck sfam scpl sdes in
|
||
let () = patch_parent_with_pevents base cpl in
|
||
let () = patch_children_with_pevents base des in
|
||
let wl, ml =
|
||
all_checks_family conf base ifam fam cpl des (scpl, sdes, None)
|
||
in
|
||
let changed, act =
|
||
let fam = Util.string_gen_family base fam in
|
||
let ip, act =
|
||
match p_getenv conf.env "ip" with
|
||
| Some i -> (
|
||
let i = iper_of_string i in
|
||
if Adef.mother cpl = i then (Adef.mother cpl, "af")
|
||
else
|
||
let a = poi base i in
|
||
match get_parents a with
|
||
| Some x when x = ifam -> (i, "aa")
|
||
| _ -> (Adef.father cpl, "af"))
|
||
| None -> (Adef.father cpl, "af")
|
||
in
|
||
match act with
|
||
| "af" ->
|
||
let gen_p =
|
||
Util.string_gen_person base (gen_person_of_person (poi base ip))
|
||
in
|
||
(U_Add_family (gen_p, fam), "af")
|
||
| _ ->
|
||
let gen_p =
|
||
Util.string_gen_person base (gen_person_of_person (poi base ip))
|
||
in
|
||
(U_Add_parent (gen_p, fam), "aa")
|
||
in
|
||
Util.commit_patches conf base;
|
||
History.record conf base changed act;
|
||
Update.delete_topological_sort conf base;
|
||
print_add_ok conf base (wl, ml) cpl des
|
||
|
||
(* If we only have two linked parents,
|
||
with one linked child and not other informations,
|
||
and if a union already exists between the parents,
|
||
edit the existing union in order to add a child.
|
||
Else, create a new union. *)
|
||
let print_add_parents o_conf base =
|
||
let conf = Update.update_conf o_conf in
|
||
let nsck = p_getenv conf.env "nsck" = Some "on" in
|
||
let sfam, scpl, sdes, _ = reconstitute_family conf base nsck in
|
||
if
|
||
sfam.marriage = Date.cdate_None
|
||
&& sfam.marriage_place = "" && sfam.marriage_note = ""
|
||
&& sfam.marriage_src = "" && sfam.witnesses = [||]
|
||
&& sfam.relation = Married && sfam.divorce = NotDivorced
|
||
&& sfam.fevents
|
||
= [
|
||
{
|
||
efam_name = Efam_Marriage;
|
||
efam_date = Date.cdate_None;
|
||
efam_place = "";
|
||
efam_reason = "";
|
||
efam_note = "";
|
||
efam_src = "";
|
||
efam_witnesses = [||];
|
||
};
|
||
]
|
||
&& sfam.comment = "" && sfam.origin_file = ""
|
||
&& sfam.fsources = Option.value ~default:"" (p_getenv conf.env "dsrc")
|
||
&& sfam.fam_index = dummy_ifam
|
||
then
|
||
match (Adef.father scpl, Adef.mother scpl, sdes.children) with
|
||
| ( (ff, fs, fo, Update.Link, _),
|
||
(mf, ms, mo, Update.Link, _),
|
||
[| (cf, cs, co, Update.Link, _) |] ) -> (
|
||
match
|
||
( person_of_key base ff fs fo,
|
||
person_of_key base mf ms mo,
|
||
person_of_key base cf cs co )
|
||
with
|
||
| Some fath, Some moth, Some child ->
|
||
let ffam = get_family @@ poi base fath in
|
||
let mfam = get_family @@ poi base moth in
|
||
let rec loop i =
|
||
if i = -1 then print_add o_conf base
|
||
else
|
||
let ifam = Array.unsafe_get ffam i in
|
||
if Array.exists (( = ) ifam) mfam then (
|
||
let f = foi base ifam in
|
||
let sfam = gen_family_of_family f in
|
||
let o_f = Util.string_gen_family base sfam in
|
||
let scpl = Gwdb.gen_couple_of_family f in
|
||
let sdes =
|
||
{
|
||
children =
|
||
Array.append (gen_descend_of_family f).children
|
||
[| child |];
|
||
}
|
||
in
|
||
patch_descend base ifam sdes;
|
||
patch_ascend base child
|
||
{ parents = Some ifam; consang = Adef.fix (-1) };
|
||
Util.commit_patches conf base;
|
||
let f' = family_of_gen_family base (sfam, scpl, sdes) in
|
||
let wl = ref [] in
|
||
let warning w = wl := w :: !wl in
|
||
CheckItem.family ~onchange:true base warning ifam f';
|
||
let n_f = Util.string_gen_family base sfam in
|
||
let hr =
|
||
U_Modify_family
|
||
( poi base child |> gen_person_of_person
|
||
|> Util.string_gen_person base,
|
||
o_f,
|
||
n_f )
|
||
in
|
||
History.record conf base hr "mf";
|
||
Update.delete_topological_sort conf base;
|
||
print_mod_ok conf base (!wl, []) scpl sdes)
|
||
else loop (i - 1)
|
||
in
|
||
loop (Array.length ffam)
|
||
| _ -> print_add o_conf base)
|
||
| _ -> print_add o_conf base
|
||
else print_add o_conf base
|
||
|
||
let print_mod_aux conf base callback =
|
||
let nsck = p_getenv conf.env "nsck" = Some "on" in
|
||
let sfam, scpl, sdes, ext = reconstitute_family conf base nsck in
|
||
let redisp = Option.is_some (p_getenv conf.env "return") in
|
||
let digest =
|
||
let ini_sfam = UpdateFam.string_family_of conf base sfam.fam_index in
|
||
Update.digest_family ini_sfam
|
||
in
|
||
if digest = get conf "digest" then
|
||
if ext || redisp then
|
||
UpdateFam.print_update_fam conf base (sfam, scpl, sdes) digest
|
||
else
|
||
match check_family conf sfam scpl with
|
||
| Some err, _ | _, Some err -> error_family conf err
|
||
| None, None ->
|
||
let sfam, sdes = strip_family sfam sdes in
|
||
callback sfam scpl sdes
|
||
else Update.error_digest conf
|
||
|
||
let family_structure base ifam =
|
||
let fam = foi base ifam in
|
||
(get_parent_array fam, get_children fam)
|
||
|
||
let print_mod o_conf base =
|
||
(* Attention ! On pense à remettre les compteurs à *)
|
||
(* zéro pour la détection des caractères interdits *)
|
||
let () = removed_string := [] in
|
||
let o_f =
|
||
let ifam =
|
||
match p_getenv o_conf.env "i" with
|
||
| Some i -> ifam_of_string i
|
||
| None -> dummy_ifam
|
||
in
|
||
Util.string_gen_family base (gen_family_of_family (foi base ifam))
|
||
in
|
||
let conf = Update.update_conf o_conf in
|
||
let callback sfam scpl sdes =
|
||
let ofs = family_structure base sfam.fam_index in
|
||
let nsck = p_getenv conf.env "nsck" = Some "on" in
|
||
let ifam, fam, cpl, des = effective_mod conf base nsck sfam scpl sdes in
|
||
let () = patch_parent_with_pevents base cpl in
|
||
let () = patch_children_with_pevents base des in
|
||
let s =
|
||
let sl =
|
||
[ fam.comment; fam.fsources; fam.marriage_note; fam.marriage_src ]
|
||
in
|
||
let sl =
|
||
let rec loop l accu =
|
||
match l with
|
||
| [] -> accu
|
||
| evt :: l -> loop l (evt.efam_note :: evt.efam_src :: accu)
|
||
in
|
||
loop fam.fevents sl
|
||
in
|
||
String.concat " " (List.map (sou base) sl)
|
||
in
|
||
Notes.update_notes_links_db base (Def.NLDB.PgFam ifam) s;
|
||
let nfs = (Adef.parent_array cpl, des.children) in
|
||
let onfs = Some (ofs, nfs) in
|
||
let wl, ml =
|
||
all_checks_family conf base ifam fam cpl des (scpl, sdes, onfs)
|
||
in
|
||
Util.commit_patches conf base;
|
||
let changed =
|
||
let ip =
|
||
match p_getenv o_conf.env "ip" with
|
||
| Some i -> iper_of_string i
|
||
| None -> dummy_iper
|
||
in
|
||
let p =
|
||
Util.string_gen_person base (gen_person_of_person (poi base ip))
|
||
in
|
||
let n_f = Util.string_gen_family base fam in
|
||
U_Modify_family (p, o_f, n_f)
|
||
in
|
||
History.record conf base changed "mf";
|
||
Update.delete_topological_sort conf base;
|
||
print_mod_ok conf base (wl, ml) cpl des
|
||
in
|
||
print_mod_aux conf base callback
|
||
|
||
let print_inv conf base =
|
||
match (p_getenv conf.env "i", p_getenv conf.env "f") with
|
||
| Some ip, Some ifam ->
|
||
let ip = iper_of_string ip in
|
||
let ifam = ifam_of_string ifam in
|
||
let p = poi base ip in
|
||
effective_inv conf base (get_iper p) p ifam;
|
||
Util.commit_patches conf base;
|
||
let changed =
|
||
let gen_p = Util.string_gen_person base (gen_person_of_person p) in
|
||
U_Invert_family (gen_p, ifam)
|
||
in
|
||
History.record conf base changed "if";
|
||
print_inv_ok conf base p
|
||
| _ -> Hutil.incorrect_request conf
|
||
|
||
let print_change_order_ok conf base =
|
||
match
|
||
(p_getenv conf.env "i", p_getenv conf.env "f", p_getint conf.env "n")
|
||
with
|
||
| Some ip, Some ifam, Some n ->
|
||
let ip = iper_of_string ip in
|
||
let ifam = ifam_of_string ifam in
|
||
let p = poi base ip in
|
||
effective_chg_order base (get_iper p) p ifam n;
|
||
Util.commit_patches conf base;
|
||
let changed =
|
||
let gen_p = Util.string_gen_person base (gen_person_of_person p) in
|
||
U_Invert_family (gen_p, ifam)
|
||
in
|
||
History.record conf base changed "if";
|
||
print_inv_ok conf base p
|
||
| _ -> Hutil.incorrect_request conf
|
||
|
||
let print_change_event_order conf base =
|
||
match p_getenv conf.env "i" with
|
||
| None -> Hutil.incorrect_request conf
|
||
| Some s ->
|
||
let ifam = Gwdb.ifam_of_string s in
|
||
let fam = foi base ifam in
|
||
let o_f = Util.string_gen_family base (gen_family_of_family fam) in
|
||
(* TODO_EVENT use Event.sorted_event *)
|
||
let ht = Hashtbl.create 50 in
|
||
let () =
|
||
ignore
|
||
@@ List.fold_left
|
||
(fun id evt ->
|
||
Hashtbl.add ht id evt;
|
||
succ id)
|
||
1 (get_fevents fam)
|
||
in
|
||
let sorted_fevents =
|
||
List.sort
|
||
(fun (_, pos1) (_, pos2) -> compare pos1 pos2)
|
||
(reconstitute_sorted_events conf 1)
|
||
in
|
||
let fevents =
|
||
List.fold_right
|
||
(fun (id, _) accu ->
|
||
try Hashtbl.find ht id :: accu
|
||
with Not_found -> failwith "Sorting event")
|
||
sorted_fevents []
|
||
in
|
||
let fam = gen_family_of_family fam in
|
||
let fam = { fam with fevents } in
|
||
let fam = update_family_with_fevents conf base fam in
|
||
patch_family base fam.fam_index fam;
|
||
let a = foi base fam.fam_index in
|
||
let cpl = Futil.parent conf.multi_parents (get_parent_array a) in
|
||
let des = { children = get_children a } in
|
||
let wl =
|
||
let wl = ref [] in
|
||
let warning w = wl := w :: !wl in
|
||
let nfam = family_of_gen_family base (fam, cpl, des) in
|
||
CheckItem.family base warning fam.fam_index nfam;
|
||
List.iter
|
||
(function
|
||
| ChangedOrderOfFamilyEvents (ifam, _, after) ->
|
||
patch_family base ifam { fam with fevents = after }
|
||
| _ -> ())
|
||
!wl;
|
||
List.rev !wl
|
||
in
|
||
Util.commit_patches conf base;
|
||
let changed =
|
||
let ip =
|
||
match p_getenv conf.env "ip" with
|
||
| Some i -> iper_of_string i
|
||
| None -> dummy_iper
|
||
in
|
||
let p =
|
||
Util.string_gen_person base (gen_person_of_person (poi base ip))
|
||
in
|
||
let n_f = Util.string_gen_family base fam in
|
||
U_Modify_family (p, o_f, n_f)
|
||
in
|
||
History.record conf base changed "mf";
|
||
print_change_event_order_ok conf base (wl, []) cpl des
|