Désolé, vous ne pouvez ajouter que des familles connectées au reste.
Cette restriction a été ajoutée par le propriétaire de cette base de
données.
";
trailer conf;
raise Update.ModErr
}
;
value family_exclude pfams efam =
let pfaml =
List.fold_right
(fun fam faml -> if fam == efam then faml else [fam :: faml])
(Array.to_list pfams) []
in
Array.of_list pfaml
;
value infer_origin_file_from_other_marriages conf base ifam ip =
let u = uoi base ip in
let rec loop i =
if i = Array.length u.family then None
else if u.family.(i) = ifam then loop (i + 1)
else
let r = (foi base u.family.(i)).origin_file in
if sou base r <> "" then Some r else loop (i + 1)
in
loop 0
;
value infer_origin_file conf base ifam ncpl ndes =
let r =
infer_origin_file_from_other_marriages conf base ifam (father ncpl)
in
let r =
if r = None then
infer_origin_file_from_other_marriages conf base ifam (mother ncpl)
else r
in
let r =
match r with
[ Some r -> r
| None ->
let afath = aoi base (father ncpl) in
let amoth = aoi base (mother ncpl) in
match (parents afath, parents amoth) with
[ (Some if1, _) when sou base (foi base if1).origin_file <> "" ->
(foi base if1).origin_file
| (_, Some if2) when sou base (foi base if2).origin_file <> "" ->
(foi base if2).origin_file
| _ ->
let rec loop i =
if i == Array.length ndes.children then
Update.insert_string base ""
else
let cifams = (uoi base ndes.children.(i)).family in
if Array.length cifams == 0 then loop (i + 1)
else if sou base (foi base cifams.(0)).origin_file <> "" then
(foi base cifams.(0)).origin_file
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
;
value update_related_witnesses base ofam_witn nfam_witn ncpl =
let mod_ippl = [] in
let mod_ippl =
List.fold_left
(fun ippl ip ->
if List.memq ip ofam_witn then ippl
else
let p = poi base ip in
if not (List.mem (father ncpl) p.related) then do {
p.related := [(father ncpl) :: p.related];
if List.mem_assoc ip ippl then ippl else [(ip, p) :: ippl]
}
else ippl)
mod_ippl nfam_witn
in
let mod_ippl =
List.fold_left
(fun ippl ip ->
if List.memq ip nfam_witn then ippl
else
let p = poi base ip in
if List.mem (father ncpl) p.related then do {
p.related := List.filter ( \<> (father ncpl)) p.related;
if List.mem_assoc ip ippl then ippl else [(ip, p) :: ippl]
}
else ippl)
mod_ippl ofam_witn
in
List.iter (fun (ip, p) -> base.func.patch_person ip p) mod_ippl
;
value effective_mod conf base sfam scpl sdes =
let fi = sfam.fam_index in
let ofam = foi base fi in
let ocpl = coi base fi in
let odes = doi base fi in
let created_p = ref [] in
let psrc =
match p_getenv conf.env "psrc" with
[ Some s -> strip_spaces s
| None -> "" ]
in
let ncpl =
map_couple_p conf.multi_parents
(Update.insert_person conf base psrc created_p) scpl
in
let nfam =
map_family_ps (Update.insert_person conf base psrc created_p)
(Update.insert_string base) sfam
in
let ndes =
map_descend_p (Update.insert_person conf base psrc created_p) sdes
in
let nfath = poi base (father ncpl) in
let nmoth = poi base (mother ncpl) in
let nfath_u = uoi base (father ncpl) in
do {
if sfam.relation <> NoSexesCheck then do {
match nfath.sex with
[ Female -> print_err_father_sex conf base nfath
| _ -> nfath.sex := Male ];
match nmoth.sex with
[ Male -> print_err_mother_sex conf base nmoth
| _ -> nmoth.sex := Female ]
}
else ();
if (father ncpl) == (mother ncpl) then print_err conf base else ();
if sfam.origin_file = "" then
nfam.origin_file :=
if sou base ofam.origin_file <> "" then ofam.origin_file
else infer_origin_file conf base fi ncpl ndes
else ();
nfam.fam_index := fi;
base.func.patch_family fi nfam;
base.func.patch_couple fi ncpl;
base.func.patch_descend fi ndes;
let oarr = parent_array ocpl in
let narr = parent_array ncpl in
for i = 0 to Array.length oarr - 1 do {
if not (array_memq oarr.(i) narr) then do {
let ou = uoi base oarr.(i) in
ou.family := family_exclude ou.family ofam.fam_index;
base.func.patch_union oarr.(i) ou
}
else ()
};
for i = 0 to Array.length narr - 1 do {
if not (array_memq narr.(i) oarr) then do {
let nu = uoi base narr.(i) in
nu.family := Array.append nu.family [| fi |];
base.func.patch_union narr.(i) nu;
}
else ()
};
let find_asc =
let cache = Hashtbl.create 101 in
fun ip ->
try Hashtbl.find cache ip with
[ Not_found ->
let a = aoi base ip in
do { Hashtbl.add cache ip a; a } ]
in
let same_parents =
(father ncpl) = (father ocpl) && (mother ncpl) = (mother ocpl)
in
Array.iter
(fun ip ->
let a = find_asc ip in
do {
set_parents a None;
if not (array_memq ip ndes.children) then
set_consang a (Adef.fix (-1))
else ()
})
odes.children;
Array.iter
(fun ip ->
let a = find_asc ip in
match parents a with
[ Some _ -> print_err_parents conf base (poi base ip)
| None ->
do {
set_parents a (Some fi);
if not (array_memq ip odes.children) || not same_parents then
set_consang a (Adef.fix (-1))
else ()
} ])
ndes.children;
Array.iter
(fun ip ->
if not (array_memq ip ndes.children) then
base.func.patch_ascend ip (find_asc ip)
else ())
odes.children;
Array.iter
(fun ip ->
if not (array_memq ip odes.children) || not same_parents then
base.func.patch_ascend ip (find_asc ip)
else ())
ndes.children;
Update.add_misc_names_for_new_persons base created_p.val;
Update.update_misc_names_of_family base nfath nfath_u;
update_related_witnesses base (Array.to_list ofam.witnesses)
(Array.to_list nfam.witnesses) ncpl;
(nfam, ncpl, ndes)
}
;
value effective_add conf base sfam scpl sdes =
let fi = Adef.ifam_of_int base.data.families.len in
let created_p = ref [] in
let psrc =
match p_getenv conf.env "psrc" with
[ Some s -> strip_spaces s
| None -> "" ]
in
let ncpl =
map_couple_p conf.multi_parents
(Update.insert_person conf base psrc created_p) scpl
in
let nfam =
map_family_ps (Update.insert_person conf base psrc created_p)
(Update.insert_string base) sfam
in
let ndes =
map_descend_p (Update.insert_person conf base psrc created_p) sdes
in
let origin_file = infer_origin_file conf base fi ncpl ndes in
let nfath_p = poi base (father ncpl) in
let nmoth_p = poi base (mother ncpl) in
let nfath_u = uoi base (father ncpl) in
let nmoth_u = uoi base (mother ncpl) in
do {
if sfam.relation <> NoSexesCheck then do {
match nfath_p.sex with
[ Female -> print_err_father_sex conf base nfath_p
| Male -> ()
| _ ->
do {
nfath_p.sex := Male; base.func.patch_person (father ncpl) nfath_p
} ];
match nmoth_p.sex with
[ Male -> print_err_mother_sex conf base nmoth_p
| Female -> ()
| _ ->
do {
nmoth_p.sex := Female; base.func.patch_person (mother ncpl) nmoth_p
} ]
}
else if (father ncpl) == (mother ncpl) then print_err conf base
else ();
nfam.fam_index := fi;
nfam.origin_file := origin_file;
base.func.patch_family fi nfam;
base.func.patch_couple fi ncpl;
base.func.patch_descend fi ndes;
nfath_u.family := Array.append nfath_u.family [| fi |];
nmoth_u.family := Array.append nmoth_u.family [| fi |];
base.func.patch_union (father ncpl) nfath_u;
base.func.patch_union (mother ncpl) nmoth_u;
Array.iter
(fun ip ->
let a = aoi base ip in
let p = poi base ip in
match parents a with
[ Some _ -> print_err_parents conf base p
| None ->
do {
set_parents a (Some fi);
set_consang a (Adef.fix (-1));
base.func.patch_ascend p.cle_index a
} ])
ndes.children;
Update.add_misc_names_for_new_persons base created_p.val;
Update.update_misc_names_of_family base nfath_p nfath_u;
update_related_witnesses base [] (Array.to_list nfam.witnesses) ncpl;
(nfam, ncpl, ndes)
}
;
value effective_inv conf base ip u ifam =
let rec loop =
fun
[ [ifam1; ifam2 :: ifaml] ->
if ifam2 = ifam then [ifam2; ifam1 :: ifaml]
else [ifam1 :: loop [ifam2 :: ifaml]]
| _ -> do { incorrect_request conf; raise Update.ModErr } ]
in
do {
u.family := Array.of_list (loop (Array.to_list u.family));
base.func.patch_union ip u
}
;
value kill_family base fam ip =
let u = uoi base ip in
let l =
List.fold_right
(fun ifam ifaml ->
if ifam == fam.fam_index then ifaml else [ifam :: ifaml])
(Array.to_list u.family) []
in
do { u.family := Array.of_list l; base.func.patch_union ip u }
;
value kill_parents base ip =
let a = aoi base ip in
do {
set_parents a None;
set_consang a (Adef.fix (-1));
base.func.patch_ascend ip a
}
;
value effective_del conf base fam =
let ifam = fam.fam_index in
let cpl = coi base ifam in
let des = doi base ifam in
do {
kill_family base fam (father cpl);
kill_family base fam (mother cpl);
Array.iter (kill_parents base) des.children;
set_father cpl (Adef.iper_of_int (-1));
set_mother cpl (Adef.iper_of_int (-1));
fam.witnesses := [| |];
des.children := [| |];
fam.comment := Update.insert_string base "";
fam.fam_index := Adef.ifam_of_int (-1);
base.func.patch_family ifam fam;
base.func.patch_couple ifam cpl;
base.func.patch_descend ifam des
}
;
value array_forall2 f a1 a2 =
if Array.length a1 <> Array.length a2 then invalid_arg "array_forall2"
else
loop 0 where rec loop i =
if i == Array.length a1 then True
else if f a1.(i) a2.(i) then loop (i + 1)
else False
;
value array_exists f a =
loop 0 where rec loop i =
if i = Array.length a then False
else if f a.(i) then True
else loop (i + 1)
;
value is_a_link =
fun
[ (_, _, _, Update.Link, _) -> True
| _ -> False ]
;
value is_created_or_already_there ochil_arr nchil schil =
not (is_a_link schil) || array_memq 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.
*)
value need_check_noloop (scpl, sdes, onfs) =
if array_exists is_a_link (parent_array scpl) &&
array_exists is_a_link sdes.children
then
match onfs with
[ Some ((opar, ochil), (npar, nchil)) ->
not
(array_forall2 (is_created_or_already_there opar) npar
(parent_array scpl)) ||
not
(array_forall2 (is_created_or_already_there ochil) nchil
sdes.children)
| None -> True ]
else False
;
value all_checks_family conf base fam cpl des scdo =
let wl = ref [] in
let error = Update.error conf base in
let warning w = wl.val := [w :: wl.val] in
do {
if need_check_noloop scdo then
Gutil.check_noloop_for_person_list base error
(Array.to_list (parent_array cpl))
else ();
Gutil.check_family base error warning fam cpl des;
List.rev wl.val
}
;
value print_family conf base wl cpl des =
let rdsrc =
match p_getenv conf.env "rdsrc" with
[ Some "on" -> p_getenv conf.env "src"
| _ -> p_getenv conf.env "dsrc" ]
in
do {
match rdsrc with
[ Some x ->
do {
conf.henv := List.remove_assoc "dsrc" conf.henv;
if x <> "" then conf.henv := [("dsrc", code_varenv x) :: conf.henv]
else ()
}
| None -> () ];
Wserver.wprint "