1303 lines
49 KiB
OCaml
1303 lines
49 KiB
OCaml
(* Copyright (c) 1998-2007 INRIA *)
|
|
|
|
open Config
|
|
open Def
|
|
open Gwdb
|
|
open Util
|
|
|
|
type update_error =
|
|
| UERR of Adef.safe_string
|
|
| UERR_sex_married of person
|
|
| UERR_sex_incoherent of base * person
|
|
| UERR_sex_undefined of string * string * int
|
|
| UERR_unknow_person of string * string * int
|
|
| UERR_already_defined of base * person * string
|
|
| UERR_own_ancestor of base * person
|
|
| UERR_digest
|
|
| UERR_bad_date of Def.dmy
|
|
| UERR_missing_field of Adef.safe_string
|
|
| UERR_already_has_parents of base * person
|
|
| UERR_missing_surname of Adef.safe_string
|
|
| UERR_missing_first_name of Adef.safe_string
|
|
| UERR_locked_base
|
|
|
|
exception ModErr of update_error
|
|
|
|
type create_info = {
|
|
ci_birth_date : date option;
|
|
ci_birth_place : string;
|
|
ci_death : death;
|
|
ci_death_date : date option;
|
|
ci_death_place : string;
|
|
ci_occupation : string;
|
|
ci_public : bool;
|
|
}
|
|
|
|
type create = Create of sex * create_info option | Link
|
|
type key = string * string * int * create * string
|
|
|
|
let maximum_lifespan = 125
|
|
|
|
let infer_death_from_dmy conf ?(max_age = maximum_lifespan) d =
|
|
(* TODO this max_age should be related to private_years_marriage *)
|
|
let age = (Date.time_elapsed d conf.today).year in
|
|
if age > max_age then OfCourseDead else DontKnowIfDead
|
|
|
|
let infer_death_from_cdate conf ?(max_age = maximum_lifespan) cdate =
|
|
match Date.cdate_to_dmy_opt cdate with
|
|
| None -> DontKnowIfDead
|
|
| Some dmy -> infer_death_from_dmy conf ~max_age dmy
|
|
|
|
let infer_death_bb conf birth bapt =
|
|
let infer_death_from_odate conf = function
|
|
| Some (Dgreg (d, _)) -> infer_death_from_dmy conf d
|
|
| Some (Dtext _) | None -> DontKnowIfDead
|
|
in
|
|
match infer_death_from_odate conf birth with
|
|
| DontKnowIfDead -> infer_death_from_odate conf bapt
|
|
| (NotDead | Death _ | DeadYoung | DeadDontKnowWhen | OfCourseDead) as
|
|
death_status ->
|
|
death_status
|
|
|
|
let infer_death_from_parents conf base fam =
|
|
let infer parent =
|
|
(* child is considered OfCourseDead if one parent is
|
|
dead more than maximum_lifespan years ago *)
|
|
let from_death =
|
|
match Date.dmy_of_death (get_death parent) with
|
|
| Some dmy -> infer_death_from_dmy conf dmy
|
|
| None -> DontKnowIfDead
|
|
in
|
|
if from_death = OfCourseDead then OfCourseDead
|
|
else
|
|
(* child is considered OfCourseDead if one parent was
|
|
born more than maximum_lifespan + 25 years ago *)
|
|
infer_death_from_cdate conf ~max_age:(maximum_lifespan + 25)
|
|
(get_birth parent)
|
|
in
|
|
let from_father = infer @@ poi base @@ get_father fam in
|
|
let from_mother = infer @@ poi base @@ get_mother fam in
|
|
let from_marriage = infer_death_from_cdate conf (get_marriage fam) in
|
|
if
|
|
Array.exists (( = ) OfCourseDead)
|
|
[| from_father; from_mother; from_marriage |]
|
|
then OfCourseDead
|
|
else DontKnowIfDead
|
|
|
|
let rec infer_death conf base p =
|
|
let death =
|
|
infer_death_bb conf
|
|
(Date.od_of_cdate (get_birth p))
|
|
(Date.od_of_cdate (get_baptism p))
|
|
in
|
|
if death <> DontKnowIfDead then death
|
|
else
|
|
let death =
|
|
let families = get_family p in
|
|
let len = Array.length families in
|
|
let rec loop_families i =
|
|
if i = len then DontKnowIfDead
|
|
else
|
|
let fam = foi base families.(i) in
|
|
match Date.cdate_to_dmy_opt (get_marriage fam) with
|
|
| Some d -> infer_death_from_dmy conf d
|
|
| None ->
|
|
let death =
|
|
let children = get_children fam in
|
|
let len = Array.length children in
|
|
let rec loop_children j =
|
|
if j = len then DontKnowIfDead
|
|
else
|
|
let death = infer_death conf base (poi base children.(j)) in
|
|
if death = OfCourseDead then OfCourseDead
|
|
else loop_children (j + 1)
|
|
in
|
|
loop_children 0
|
|
in
|
|
if death = OfCourseDead then OfCourseDead
|
|
else loop_families (i + 1)
|
|
in
|
|
loop_families 0
|
|
in
|
|
if death <> DontKnowIfDead then death
|
|
else
|
|
match get_parents p with
|
|
| None -> DontKnowIfDead
|
|
| Some ifam -> infer_death_from_parents conf base (foi base ifam)
|
|
|
|
(*let restrict_to_small_list el =
|
|
let rec begin_list n rl el =
|
|
TODO suppress this limit
|
|
if n > 25 then
|
|
let rec end_list n sl el =
|
|
if n > 25 then List.rev_append rl (None :: sl)
|
|
else
|
|
match el with
|
|
e :: el -> end_list (n + 1) (Some e :: sl) el
|
|
| [] -> List.rev_append rl sl
|
|
in
|
|
end_list 0 [] (List.rev el)
|
|
else
|
|
match el with
|
|
e :: el -> begin_list (n + 1) (Some e :: rl) el
|
|
| [] -> List.rev rl
|
|
in
|
|
begin_list 0 [] el*)
|
|
|
|
(* ************************************************************************** *)
|
|
(* [Fonc] print_person_parents_and_spouses :
|
|
config -> base -> person -> unit *)
|
|
|
|
(* ************************************************************************** *)
|
|
|
|
(* ************************************************************************** *)
|
|
|
|
(** [Description] : Print several information to distinguish homonyms. The
|
|
information includes name of the person, name of the parents,
|
|
name of the spouse.
|
|
[Args] :
|
|
- conf : configuration of the base
|
|
- base : base
|
|
- p : person
|
|
[Retour] : unit
|
|
[Rem] : Not visible. *)
|
|
let print_person_parents_and_spouses conf base p =
|
|
Output.print_sstring conf {|<a href="|};
|
|
Output.print_string conf (commd conf);
|
|
Output.print_string conf (acces conf base p);
|
|
Output.print_sstring conf {|">|};
|
|
Output.print_string conf (escape_html @@ p_first_name base p);
|
|
Output.print_sstring conf ".";
|
|
Output.print_sstring conf (string_of_int @@ get_occ p);
|
|
Output.print_sstring conf " ";
|
|
Output.print_string conf (escape_html @@ p_surname base p);
|
|
Output.print_sstring conf "</a>";
|
|
let pub_name = sou base (get_public_name p) in
|
|
if pub_name <> "" then
|
|
Output.print_sstring conf (Printf.sprintf " (%s)" pub_name);
|
|
Output.print_string conf (DateDisplay.short_dates_text conf base p);
|
|
let cop = Util.child_of_parent conf base p in
|
|
if String.length (cop :> string) > 0 then (
|
|
Output.print_sstring conf ", ";
|
|
Output.print_string conf cop);
|
|
let hbw = Util.husband_wife conf base p true in
|
|
if String.length (hbw :> string) > 0 then (
|
|
Output.print_sstring conf ", ";
|
|
Output.print_string conf hbw);
|
|
Output.print_sstring conf ". "
|
|
|
|
let print_same_name conf base p =
|
|
match Gutil.find_same_name base p with
|
|
| [ _ ] -> ()
|
|
| pl ->
|
|
Output.print_sstring conf "<p>";
|
|
Output.print_sstring conf
|
|
@@ Utf8.capitalize_fst (transl conf "persons having the same name");
|
|
Output.print_sstring conf (transl conf ":");
|
|
Output.print_sstring conf "<ul>";
|
|
List.iter
|
|
(fun p ->
|
|
Output.print_sstring conf "<li>";
|
|
print_person_parents_and_spouses conf base p;
|
|
Output.print_sstring conf "</li>")
|
|
pl;
|
|
Output.print_sstring conf "</ul></p>"
|
|
|
|
(* ************************************************************************* *)
|
|
(* [Fonc] is_label_note : string -> bool *)
|
|
|
|
(* ************************************************************************* *)
|
|
|
|
(** [Description] : Test si le label contient le mot 'note' pour savoir si
|
|
dans les évènement secondaires, il faut traiter la note comme un
|
|
textarea.
|
|
[Args] :
|
|
- lbl : le label
|
|
[Retour] :
|
|
- bool
|
|
[Rem] : Non exporté en clair hors de ce module. *)
|
|
let is_label_note lbl =
|
|
let rec loop i =
|
|
if i = String.length lbl then false
|
|
else if lbl.[i] = 'n' then
|
|
let note = "note" in
|
|
if String.length note + i <= String.length lbl then
|
|
let sub_x = String.sub lbl i (String.length note) in
|
|
if sub_x = note then true else loop (i + String.length note)
|
|
else false
|
|
else loop (i + 1)
|
|
in
|
|
loop 0
|
|
|
|
let print_aux conf param (value : Adef.encoded_string)
|
|
(submit : Adef.encoded_string) =
|
|
Output.printf conf {|<p><form method="post" action="%s">|} conf.command;
|
|
List.iter (fun (x, v) -> Util.hidden_textarea conf x v) conf.henv;
|
|
List.iter (fun (x, v) -> Util.hidden_textarea conf x v) conf.env;
|
|
Util.hidden_input conf param value;
|
|
Output.print_sstring conf {|<input type="submit" value="|};
|
|
Output.print_string conf submit;
|
|
Output.print_sstring conf {|"></form></p>|}
|
|
|
|
let print_return conf =
|
|
print_aux conf "return" (Adef.encoded "ok")
|
|
(Adef.encoded @@ Utf8.capitalize_fst @@ transl conf "back")
|
|
|
|
let print_continue conf
|
|
?(continue = Adef.encoded @@ Utf8.capitalize_fst @@ transl conf "continue")
|
|
param value =
|
|
print_aux conf param value continue
|
|
|
|
let prerr conf _err fn =
|
|
if not conf.api_mode then (
|
|
let title _ =
|
|
Output.print_sstring conf (Utf8.capitalize_fst (transl conf "error"))
|
|
in
|
|
Hutil.rheader conf title;
|
|
fn ();
|
|
Hutil.trailer conf;
|
|
Output.flush conf);
|
|
raise @@ ModErr _err
|
|
|
|
let string_of_error conf =
|
|
let fso f s o : Adef.escaped_string =
|
|
Util.escape_html f ^^^ "." ^<^ string_of_int o ^<^ " "
|
|
^<^ Util.escape_html s
|
|
in
|
|
let fso_p base p =
|
|
let f = Gwdb.get_first_name p |> Gwdb.sou base |> Name.lower in
|
|
let s = Gwdb.get_surname p |> Gwdb.sou base |> Name.lower in
|
|
let o = get_occ p in
|
|
fso f s o
|
|
in
|
|
let strong s = ("<strong>" ^<^ s ^>^ "</strong>" :> Adef.safe_string) in
|
|
function
|
|
| UERR s -> s
|
|
| UERR_sex_married _ ->
|
|
Utf8.capitalize_fst (transl conf "cannot change sex of a married person")
|
|
|> Adef.safe
|
|
| UERR_sex_incoherent (base, p) ->
|
|
(Utf8.capitalize_fst (fso_p base p :> string)
|
|
^ " "
|
|
^
|
|
if get_sex p = Female then transl conf "should be male"
|
|
else transl conf "should be female")
|
|
|> Adef.safe
|
|
| UERR_sex_undefined (f, s, o) ->
|
|
Printf.sprintf
|
|
(fcapitale (ftransl conf "undefined sex for %t"))
|
|
(fun _ -> (fso f s o :> string))
|
|
|> Adef.safe
|
|
| UERR_unknow_person (f, s, o) ->
|
|
Utf8.capitalize_fst (transl conf "unknown person")
|
|
^<^ transl conf ":" ^<^ " "
|
|
^<^ strong (fso f s o)
|
|
| UERR_already_defined (base, p, var) ->
|
|
(Printf.sprintf
|
|
(fcapitale (ftransl conf "name %s already used by %tthis person%t"))
|
|
("\"" ^ (fso_p base p :> string) ^ "\"")
|
|
(fun _ ->
|
|
Printf.sprintf "<a href=\"%s%s\">"
|
|
(commd conf : Adef.escaped_string :> string)
|
|
(acces conf base p : Adef.escaped_string :> string))
|
|
(fun _ -> "</a>")
|
|
^
|
|
if var = "" then "."
|
|
else
|
|
"<span class=\"UERR_already_defined_var\">("
|
|
^ (Util.escape_html var : Adef.escaped_string :> string)
|
|
^ ")</span>.")
|
|
|> Adef.safe
|
|
| UERR_own_ancestor (base, p) ->
|
|
strong (fso_p base p)
|
|
^>^ " "
|
|
^ transl conf "would be his/her own ancestor"
|
|
| UERR_digest ->
|
|
transl conf
|
|
{|the base has changed; do "back", "reload", and refill the form|}
|
|
|> Utf8.capitalize_fst |> Adef.safe
|
|
| UERR_bad_date d ->
|
|
(Utf8.capitalize_fst (transl conf "incorrect date")
|
|
^ transl conf ":" ^ " "
|
|
^
|
|
match d with
|
|
| { day = 0; month = 0; year = a } -> Printf.sprintf "%d" a
|
|
| { day = 0; month = m; year = a } -> Printf.sprintf "%d/%d" m a
|
|
| { day = j; month = m; year = a } -> Printf.sprintf "%d/%d/%d" j m a)
|
|
|> Adef.safe
|
|
| UERR_missing_field s -> "missing field: " ^<^ s
|
|
| UERR_already_has_parents (base, p) ->
|
|
Printf.sprintf
|
|
(fcapitale (ftransl conf "%t already has parents"))
|
|
(fun _ ->
|
|
(Util.referenced_person_text conf base p : Adef.safe_string :> string))
|
|
|> Adef.safe
|
|
| UERR_missing_first_name s when s = Adef.safe "" ->
|
|
transl conf "first name missing" |> Utf8.capitalize_fst |> Adef.safe
|
|
| UERR_missing_first_name x ->
|
|
(transl conf "first name missing" |> Utf8.capitalize_fst)
|
|
^<^ transl conf ":" ^<^ " "
|
|
^<^ (x :> Adef.safe_string)
|
|
| UERR_missing_surname x ->
|
|
(transl conf "surname missing" |> Utf8.capitalize_fst)
|
|
^<^ transl conf ":" ^<^ " "
|
|
^<^ (x :> Adef.safe_string)
|
|
| UERR_locked_base ->
|
|
transl conf "the file is temporarily locked: please try again"
|
|
|> Utf8.capitalize_fst |> Adef.safe
|
|
|
|
let print_err_unknown conf (f, s, o) =
|
|
let err = UERR_unknow_person (f, s, o) in
|
|
prerr conf err @@ fun () ->
|
|
Output.print_string conf (string_of_error conf err);
|
|
print_return conf
|
|
|
|
let delete_topological_sort_v conf _base =
|
|
let bfile = Util.bpath (conf.bname ^ ".gwb") in
|
|
let tstab_file = Filename.concat bfile "tstab_visitor" in
|
|
Mutil.rm tstab_file;
|
|
let tstab_file = Filename.concat bfile "restrict" in
|
|
Mutil.rm tstab_file
|
|
|
|
let delete_topological_sort conf base =
|
|
let _ = delete_topological_sort_v conf base in
|
|
let bfile = Util.bpath (conf.bname ^ ".gwb") in
|
|
let tstab_file = Filename.concat bfile "tstab" in
|
|
Mutil.rm tstab_file
|
|
|
|
let print_someone conf base p =
|
|
Output.printf conf "%s%s %s" (p_first_name base p)
|
|
(if get_occ p = 0 then "" else "." ^ string_of_int (get_occ p))
|
|
(p_surname base p)
|
|
|
|
let print_first_name conf base p =
|
|
Output.print_string conf (Util.escape_html @@ p_first_name base p);
|
|
if get_occ p <> 0 then (
|
|
Output.print_sstring conf ".";
|
|
Output.print_sstring conf @@ string_of_int (get_occ p))
|
|
|
|
let someone_strong base p =
|
|
"<strong>"
|
|
^<^ escape_html (p_first_name base p)
|
|
^^^ (if get_occ p = 0 then Adef.escaped ""
|
|
else Adef.escaped @@ "." ^ string_of_int (get_occ p))
|
|
^^^ " "
|
|
^<^ escape_html (p_surname base p)
|
|
^>^ "</strong>"
|
|
|
|
let print_first_name_strong conf base p =
|
|
Output.printf conf "<strong>%s%s</strong>" (p_first_name base p)
|
|
(if get_occ p = 0 then "" else "." ^ string_of_int (get_occ p))
|
|
|
|
let print_error conf e = Output.print_string conf @@ string_of_error conf e
|
|
|
|
let print_someone_ref_text conf base p =
|
|
Output.print_sstring conf {|<a href="|};
|
|
Output.print_string conf (commd conf);
|
|
Output.print_string conf (acces conf base p);
|
|
Output.print_sstring conf {|">|};
|
|
Output.print_string conf (escape_html @@ p_first_name base p);
|
|
if get_occ p <> 0 then (
|
|
Output.print_sstring conf ".";
|
|
Output.print_sstring conf (string_of_int (get_occ p)));
|
|
Output.print_sstring conf " ";
|
|
Output.print_string conf (escape_html @@ p_surname base p);
|
|
Output.print_sstring conf "</a>"
|
|
|
|
let print_list_aux conf base title list printer =
|
|
if list <> [] then (
|
|
Output.printf conf "%s\n<ul>" (Utf8.capitalize_fst (transl conf title));
|
|
printer conf base list;
|
|
Output.print_sstring conf "</ul>")
|
|
|
|
let print_order_changed conf print_list before after =
|
|
let bef_d, aft_d = Difference.f before after in
|
|
Output.print_sstring conf (Util.transl conf ":");
|
|
Output.print_sstring conf
|
|
{|<table style="margin:1em"><tr><td><ul style="list-style-type:none">|};
|
|
print_list before bef_d;
|
|
Output.print_sstring conf {|</ul></td><td><ul style="list-style-type:none">|};
|
|
print_list after aft_d;
|
|
Output.print_sstring conf {|</ul></td></tr></table>|}
|
|
|
|
let someone_strong_n_short_dates conf base p =
|
|
(someone_strong base p :> Adef.safe_string)
|
|
^^^ DateDisplay.short_dates_text conf base p
|
|
|
|
let print_warning conf base = function
|
|
| BigAgeBetweenSpouses (p1, p2, a) ->
|
|
Output.printf conf
|
|
(fcapitale
|
|
(ftransl conf
|
|
"the difference of age between %t and %t is quite important"))
|
|
(fun _ -> (someone_strong base p1 :> string))
|
|
(fun _ -> (someone_strong base p2 :> string));
|
|
Output.print_sstring conf (transl conf ":");
|
|
Output.print_sstring conf " ";
|
|
Output.print_string conf (DateDisplay.string_of_age conf a)
|
|
| BirthAfterDeath p ->
|
|
Output.printf conf (ftransl conf "%t died before his/her birth") (fun _ ->
|
|
(someone_strong_n_short_dates conf base p :> string))
|
|
| ChangedOrderOfChildren (ifam, _, before, after) ->
|
|
let cpl = foi base ifam in
|
|
let fath = poi base (get_father cpl) in
|
|
let moth = poi base (get_mother cpl) in
|
|
let print_list arr diff_arr =
|
|
Array.iteri
|
|
(fun i p ->
|
|
let p = poi base p in
|
|
Output.print_sstring conf "<li";
|
|
if diff_arr.(i) then
|
|
Output.print_sstring conf {| style="background:pink"|};
|
|
Output.print_sstring conf ">";
|
|
Output.print_sstring conf "\n";
|
|
if eq_istr (get_surname p) (get_surname fath) then
|
|
print_first_name conf base p
|
|
else print_someone conf base p;
|
|
Output.print_string conf (DateDisplay.short_dates_text conf base p);
|
|
Output.print_sstring conf "\n";
|
|
Output.print_sstring conf "</li>\n")
|
|
arr
|
|
in
|
|
Output.print_sstring conf
|
|
(Utf8.capitalize_fst (transl conf "changed order of children"));
|
|
Output.print_sstring conf "\n";
|
|
print_someone_ref_text conf base fath;
|
|
Output.print_sstring conf " ";
|
|
Output.print_sstring conf (transl_nth conf "and" 0);
|
|
Output.print_sstring conf " ";
|
|
print_someone_ref_text conf base moth;
|
|
print_order_changed conf print_list before after
|
|
| ChildrenNotInOrder (ifam, _, elder, x) ->
|
|
let cpl = foi base ifam in
|
|
Output.printf conf
|
|
(fcapitale
|
|
(ftransl conf "the following children of %t and %t are not in order"))
|
|
(fun _ -> (someone_strong base (poi base (get_father cpl)) :> string))
|
|
(fun _ -> (someone_strong base (poi base (get_mother cpl)) :> string));
|
|
Output.print_sstring conf ":\n<ul><li>";
|
|
print_first_name_strong conf base elder;
|
|
Output.print_string conf (DateDisplay.short_dates_text conf base elder);
|
|
Output.print_sstring conf "</li><li>";
|
|
print_first_name_strong conf base x;
|
|
Output.print_string conf (DateDisplay.short_dates_text conf base x);
|
|
Output.print_sstring conf "</li></ul>\n"
|
|
| ChangedOrderOfMarriages (p, before, after) ->
|
|
let print_list arr diff_arr =
|
|
Array.iteri
|
|
(fun i ifam ->
|
|
let fam = foi base ifam in
|
|
let sp = Gutil.spouse (get_iper p) fam in
|
|
let sp = poi base sp in
|
|
Output.print_sstring conf "<li";
|
|
if diff_arr.(i) then
|
|
Output.print_sstring conf {| style="background:pink"|};
|
|
Output.print_sstring conf ">\n";
|
|
print_first_name conf base p;
|
|
Output.print_sstring conf " &";
|
|
Output.print_string conf
|
|
(DateDisplay.short_marriage_date_text conf base fam p sp);
|
|
Output.print_sstring conf "\n";
|
|
print_someone conf base sp;
|
|
Output.print_sstring conf "\n</li>\n")
|
|
arr
|
|
in
|
|
Output.print_sstring conf
|
|
(Utf8.capitalize_fst (transl conf "changed order of marriages"));
|
|
print_order_changed conf print_list before after
|
|
| ChangedOrderOfFamilyEvents (_, before, after) ->
|
|
let print_list arr diff_arr =
|
|
Array.iteri
|
|
(fun i evt ->
|
|
let name = Util.string_of_fevent_name conf base evt.efam_name in
|
|
Output.print_sstring conf "<li";
|
|
if diff_arr.(i) then
|
|
Output.print_sstring conf {| style="background:pink"|};
|
|
Output.print_sstring conf ">";
|
|
Output.print_string conf name;
|
|
Output.print_sstring conf "</li>")
|
|
arr
|
|
in
|
|
let before = Array.of_list before in
|
|
let after = Array.of_list after in
|
|
Output.printf conf "%s\n"
|
|
(Utf8.capitalize_fst (transl conf "changed order of family's events"));
|
|
print_order_changed conf print_list before after
|
|
| ChangedOrderOfPersonEvents (_, before, after) ->
|
|
let print_list arr diff_arr =
|
|
Array.iteri
|
|
(fun i evt ->
|
|
let name = Util.string_of_pevent_name conf base evt.epers_name in
|
|
Output.print_sstring conf "<li";
|
|
if diff_arr.(i) then
|
|
Output.print_sstring conf {| style="background:pink"|};
|
|
Output.print_sstring conf ">";
|
|
Output.print_string conf name;
|
|
Output.print_sstring conf "</li>")
|
|
arr
|
|
in
|
|
Output.print_sstring conf
|
|
(Utf8.capitalize_fst (transl conf "changed order of person's events"));
|
|
let before = Array.of_list before in
|
|
let after = Array.of_list after in
|
|
print_order_changed conf print_list before after
|
|
| CloseChildren (ifam, c1, c2) ->
|
|
let cpl = foi base ifam in
|
|
Output.printf conf
|
|
(fcapitale
|
|
(ftransl conf
|
|
"the following children of %t and %t are born very close"))
|
|
(fun _ -> (someone_strong base (poi base (get_father cpl)) :> string))
|
|
(fun _ -> (someone_strong base (poi base (get_mother cpl)) :> string));
|
|
Output.print_sstring conf ":\n<ul><li>";
|
|
print_first_name_strong conf base c1;
|
|
Output.print_string conf (DateDisplay.short_dates_text conf base c1);
|
|
Output.print_sstring conf "</li><li>";
|
|
print_first_name_strong conf base c2;
|
|
Output.print_string conf (DateDisplay.short_dates_text conf base c2);
|
|
Output.print_sstring conf "</li></ul>\n"
|
|
| DistantChildren (ifam, p1, p2) ->
|
|
let cpl = foi base ifam in
|
|
Output.printf conf
|
|
(fcapitale
|
|
(ftransl conf
|
|
"the following children of %t and %t are born very distant"))
|
|
(fun _ -> (someone_strong base (poi base (get_father cpl)) :> string))
|
|
(fun _ -> (someone_strong base (poi base (get_mother cpl)) :> string));
|
|
Output.print_sstring conf ":<ul><li>";
|
|
print_first_name_strong conf base p1;
|
|
Output.print_string conf (DateDisplay.short_dates_text conf base p1);
|
|
Output.print_sstring conf "</li><li>";
|
|
print_first_name_strong conf base p2;
|
|
Output.print_string conf (DateDisplay.short_dates_text conf base p2);
|
|
Output.print_sstring conf "</li></ul>"
|
|
| DeadOld (p, a) ->
|
|
Output.print_string conf (someone_strong base p);
|
|
Output.print_sstring conf " ";
|
|
Output.print_sstring conf
|
|
(transl_nth conf "died at an advanced age" @@ index_of_sex @@ get_sex p);
|
|
Output.print_sstring conf "(";
|
|
Output.print_string conf (DateDisplay.string_of_age conf a);
|
|
Output.print_sstring conf ")"
|
|
| DeadTooEarlyToBeFather (father, child) ->
|
|
Output.printf conf
|
|
(ftransl conf
|
|
"%t is born more than 2 years after the death of his/her father %t")
|
|
(fun _ -> (someone_strong_n_short_dates conf base child :> string))
|
|
(fun _ -> (someone_strong_n_short_dates conf base father :> string))
|
|
| FEventOrder (p, e1, e2) ->
|
|
Output.printf conf
|
|
(fcapitale (ftransl conf "%t's %s before his/her %s"))
|
|
(fun _ -> (someone_strong base p :> string))
|
|
(Util.string_of_fevent_name conf base e1.efam_name :> string)
|
|
(Util.string_of_fevent_name conf base e2.efam_name :> string)
|
|
| FWitnessEventAfterDeath (p, e, _) ->
|
|
Output.printf conf
|
|
(fcapitale (ftransl conf "%t witnessed the %s after his/her death"))
|
|
(fun _ -> (someone_strong_n_short_dates conf base p :> string))
|
|
(Util.string_of_fevent_name conf base e.efam_name :> string)
|
|
| FWitnessEventBeforeBirth (p, e, _) ->
|
|
Output.printf conf
|
|
(fcapitale (ftransl conf "%t witnessed the %s before his/her birth"))
|
|
(fun _ -> (someone_strong_n_short_dates conf base p :> string))
|
|
(Util.string_of_fevent_name conf base e.efam_name :> string)
|
|
| IncoherentSex (p, _, _) ->
|
|
Output.printf conf
|
|
(fcapitale
|
|
(ftransl conf "%t's sex is not coherent with his/her relations"))
|
|
(fun _ -> (someone_strong base p :> string))
|
|
| IncoherentAncestorDate (anc, p) ->
|
|
Output.printf conf "%s has a younger ancestor %s"
|
|
(someone_strong base p :> string)
|
|
(someone_strong base anc :> string)
|
|
| MarriageDateAfterDeath p ->
|
|
Output.printf conf
|
|
(fcapitale (ftransl conf "marriage had occurred after the death of %t"))
|
|
(fun _ -> (someone_strong_n_short_dates conf base p :> string))
|
|
| MarriageDateBeforeBirth p ->
|
|
Output.printf conf
|
|
(fcapitale
|
|
(ftransl conf "marriage had occurred before the birth of %t"))
|
|
(fun _ -> (someone_strong_n_short_dates conf base p :> string))
|
|
| MotherDeadBeforeChildBirth (mother, child) ->
|
|
Output.printf conf
|
|
(ftransl conf "%t is born after the death of his/her mother %t")
|
|
(fun _ -> (someone_strong_n_short_dates conf base child :> string))
|
|
(fun _ -> (someone_strong_n_short_dates conf base mother :> string))
|
|
| ParentBornAfterChild (p, c) ->
|
|
Output.print_string conf (someone_strong base p);
|
|
Output.print_sstring conf " ";
|
|
Output.print_sstring conf (transl conf "is born after his/her child");
|
|
Output.print_sstring conf " ";
|
|
Output.print_string conf (someone_strong base c)
|
|
| ParentTooYoung (p, a, _) ->
|
|
Output.print_string conf (someone_strong base p);
|
|
Output.print_sstring conf " ";
|
|
Output.print_sstring conf (transl conf "is a very young parent");
|
|
Output.print_sstring conf " (";
|
|
Output.print_string conf (DateDisplay.string_of_age conf a);
|
|
Output.print_sstring conf ")"
|
|
| ParentTooOld (p, a, _) ->
|
|
Output.print_string conf (someone_strong base p);
|
|
Output.print_sstring conf " ";
|
|
Output.print_sstring conf (transl conf "is a very old parent");
|
|
Output.print_sstring conf " (";
|
|
Output.print_string conf (DateDisplay.string_of_age conf a);
|
|
Output.print_sstring conf ")"
|
|
| PossibleDuplicateFam (f1, _) ->
|
|
let f = foi base f1 in
|
|
Output.printf conf
|
|
(fcapitale (ftransl conf "%s and %s have several unions"))
|
|
(someone_strong base @@ poi base @@ get_father f :> string)
|
|
(someone_strong base @@ poi base @@ get_mother f :> string)
|
|
| PossibleDuplicateFamHomonymous (f1, _, p) ->
|
|
let f = foi base f1 in
|
|
let fath = get_father f in
|
|
let moth = get_mother f in
|
|
let curr, hom =
|
|
if eq_iper fath (get_iper p) then (moth, fath) else (fath, moth)
|
|
in
|
|
Output.printf conf
|
|
(fcapitale (ftransl conf "%s has unions with several persons named %s"))
|
|
(someone_strong base @@ poi base @@ curr :> string)
|
|
(someone_strong base @@ poi base @@ hom :> string)
|
|
| PEventOrder (p, e1, e2) ->
|
|
Output.printf conf
|
|
(fcapitale (ftransl conf "%t's %s before his/her %s"))
|
|
(fun _ -> (someone_strong base p :> string))
|
|
(Util.string_of_pevent_name conf base e1.epers_name :> string)
|
|
(Util.string_of_pevent_name conf base e2.epers_name :> string)
|
|
| PWitnessEventAfterDeath (p, e, _origin) ->
|
|
Output.printf conf
|
|
(fcapitale (ftransl conf "%t witnessed the %s after his/her death"))
|
|
(fun _ -> (someone_strong_n_short_dates conf base p :> string))
|
|
(Util.string_of_pevent_name conf base e.epers_name :> string)
|
|
| PWitnessEventBeforeBirth (p, e, _origin) ->
|
|
Output.printf conf
|
|
(fcapitale (ftransl conf "%t witnessed the %s before his/her birth"))
|
|
(fun _ -> (someone_strong_n_short_dates conf base p :> string))
|
|
(Util.string_of_pevent_name conf base e.epers_name :> string)
|
|
| TitleDatesError (p, t) ->
|
|
Output.printf conf
|
|
(fcapitale (ftransl conf "%t has incorrect title dates: %t"))
|
|
(fun _ -> (someone_strong_n_short_dates conf base p :> string))
|
|
(fun _ ->
|
|
("<strong>"
|
|
^<^ (safe_html @@ sou base t.t_ident)
|
|
^^^ " "
|
|
^<^ (safe_html @@ sou base t.t_place)
|
|
^^^ "</strong> <em>"
|
|
^<^ (match Date.od_of_cdate t.t_date_start with
|
|
| Some d -> DateDisplay.string_of_date conf d
|
|
| None -> Adef.safe "")
|
|
^^^ "-"
|
|
^<^ (match Date.od_of_cdate t.t_date_end with
|
|
| Some d -> DateDisplay.string_of_date conf d
|
|
| None -> Adef.safe "")
|
|
^>^ "</em>"
|
|
:> string))
|
|
| UndefinedSex p ->
|
|
Output.printf conf
|
|
(fcapitale (ftransl conf "undefined sex for %t"))
|
|
(fun _ -> (someone_strong base p :> string))
|
|
| YoungForMarriage (p, a, _) | OldForMarriage (p, a, _) ->
|
|
Output.print_string conf (someone_strong base p);
|
|
Output.print_sstring conf " ";
|
|
Output.printf conf (ftransl conf "married at age %t") (fun _ ->
|
|
(DateDisplay.string_of_age conf a :> string))
|
|
|
|
let print_warnings conf base wl =
|
|
print_list_aux conf base "warnings" wl @@ fun conf base wl ->
|
|
(* On rend la liste unique, parce qu'il se peut qu'un warning soit *)
|
|
(* levé par plusieurs fonctions différents selon le context. *)
|
|
let wl = List.sort_uniq compare wl in
|
|
List.iter
|
|
(fun w ->
|
|
Output.print_sstring conf "<li>";
|
|
print_warning conf base w;
|
|
Output.print_sstring conf "</li>")
|
|
wl
|
|
|
|
(* ************************************************************************* *)
|
|
(* [Fonc] print_misc : config -> base -> Def.misc -> unit *)
|
|
|
|
(* ************************************************************************* *)
|
|
|
|
(** [Description] : Fonction d'impression des 'informations diverses'.
|
|
[Args] :
|
|
- conf : configuration
|
|
- base : base
|
|
- fun : Def.misc (miscellaneous)
|
|
[Retour] :
|
|
- unit
|
|
[Rem] : Non exporté en clair hors de ce module. *)
|
|
let print_misc conf _base = function
|
|
| MissingSources ->
|
|
Output.print_sstring conf "<em>";
|
|
Output.printf conf "%s\n"
|
|
(Utf8.capitalize_fst (transl conf "missing sources"));
|
|
Output.print_sstring conf "</em>"
|
|
|
|
(* ************************************************************************* *)
|
|
(* [Fonc] print_miscs : config -> base -> Def.misc list -> unit *)
|
|
|
|
(* ************************************************************************* *)
|
|
|
|
(** [Description] : Affiche la liste des 'informations diverses'.
|
|
[Args] :
|
|
- conf : configuration
|
|
- base : base
|
|
- ml : Def.misc list (miscellaneous)
|
|
[Retour] :
|
|
- unit
|
|
[Rem] : Exporté en clair hors de ce module. *)
|
|
let print_miscs conf base ml =
|
|
print_list_aux conf base "miscellaneous informations" ml @@ fun conf base ->
|
|
List.iter (fun m ->
|
|
Output.print_sstring conf "<li>";
|
|
print_misc conf base m;
|
|
Output.print_sstring conf "</li>")
|
|
|
|
(* ************************************************************************* *)
|
|
(* [Fonc] print_miscs :
|
|
config -> base -> (Def.warning list * Def.misc list) -> unit *)
|
|
|
|
(* ************************************************************************* *)
|
|
|
|
(** [Description] : Affiche sous la même rubrique, la liste des warnings
|
|
et la liste des 'informations diverses'.
|
|
[Args] :
|
|
- conf : configuration
|
|
- base : base
|
|
- wl : Def.warning list
|
|
- ml : Def.misc list (miscellaneous)
|
|
[Retour] :
|
|
- unit
|
|
[Rem] : Exporté en clair hors de ce module. *)
|
|
let print_warnings_and_miscs conf base wl ml =
|
|
if wl <> [] || ml <> [] then (
|
|
Output.printf conf "%s\n" (Utf8.capitalize_fst (transl conf "warnings"));
|
|
Output.print_sstring conf "<ul>\n";
|
|
List.iter
|
|
(fun w ->
|
|
Output.print_sstring conf "<li>";
|
|
print_warning conf base w;
|
|
Output.print_sstring conf "</li>")
|
|
wl;
|
|
List.iter
|
|
(fun m ->
|
|
Output.print_sstring conf "<li>";
|
|
print_misc conf base m;
|
|
Output.print_sstring conf "</li>")
|
|
ml;
|
|
Output.print_sstring conf "</ul>\n")
|
|
|
|
let error conf err =
|
|
prerr conf err @@ fun () ->
|
|
Output.print_string conf (string_of_error conf err);
|
|
Output.print_sstring conf "\n";
|
|
print_return conf
|
|
|
|
let def_error conf base x =
|
|
error conf
|
|
@@
|
|
match x with
|
|
| AlreadyDefined p -> UERR_already_defined (base, p, "")
|
|
| OwnAncestor p -> UERR_own_ancestor (base, p)
|
|
| BadSexOfMarriedPerson p -> UERR_sex_married p
|
|
|
|
let error_locked conf =
|
|
let err = UERR_locked_base in
|
|
prerr conf err @@ fun () ->
|
|
Output.print_sstring conf "<p>\n";
|
|
transl conf "the file is temporarily locked: please try again"
|
|
|> Utf8.capitalize_fst |> Output.print_sstring conf;
|
|
Output.print_sstring conf {|.</p><table><tr><td><form method="post" action="|};
|
|
Output.print_sstring conf conf.command;
|
|
Output.print_sstring conf {|">|};
|
|
let aux env =
|
|
List.iter
|
|
(fun (x, v) ->
|
|
if x = "retry" then ()
|
|
else if x = "notes" || is_label_note x then
|
|
Util.hidden_textarea conf x v
|
|
else Util.hidden_input conf x v)
|
|
env
|
|
in
|
|
aux conf.henv;
|
|
aux conf.env;
|
|
(* just to see in the traces... *)
|
|
Util.hidden_input conf "retry" (Mutil.encode conf.user);
|
|
Util.hidden_input conf "submit"
|
|
(transl conf "try again" |> Utf8.capitalize_fst |> Mutil.encode);
|
|
Output.print_sstring conf {|</form></td><td><form method="get" action="|};
|
|
Output.print_sstring conf conf.command;
|
|
Output.print_sstring conf {|">|};
|
|
Util.hidden_env_aux conf conf.henv;
|
|
(match
|
|
match p_getenv conf.env "ip" with
|
|
| Some ip -> Some ip
|
|
| None -> p_getenv conf.env "i"
|
|
with
|
|
| Some n -> Util.hidden_input conf "i" (Mutil.encode n)
|
|
| None -> ());
|
|
transl_nth conf "user/password/cancel" 2
|
|
|> Utf8.capitalize_fst |> Mutil.encode
|
|
|> Util.hidden_input conf "submit";
|
|
Output.print_sstring conf "</form></td></tr></table>"
|
|
|
|
let error_digest conf =
|
|
let err = UERR_digest in
|
|
prerr conf err @@ fun () ->
|
|
Hutil.print_link_to_welcome conf true;
|
|
Output.print_sstring conf "<p>";
|
|
Output.print_string conf (string_of_error conf err);
|
|
Output.print_sstring conf "</p>"
|
|
|
|
let digest_person p = Marshal.to_string p [] |> Mutil.digest
|
|
let digest_family f = Marshal.to_string f [] |> Mutil.digest
|
|
|
|
let get var key env =
|
|
match p_getenv env (var ^ "_" ^ key) with
|
|
| Some v -> v
|
|
| None -> failwith (var ^ "_" ^ key ^ " unbound")
|
|
|
|
let get_number var key env =
|
|
match p_getint env (var ^ "_" ^ key) with
|
|
| Some x when x <> 0 -> Some x
|
|
| Some _ | None -> None
|
|
|
|
let bad_date conf d =
|
|
let err = UERR_bad_date d in
|
|
prerr conf err @@ fun () ->
|
|
Output.print_string conf (string_of_error conf err)
|
|
|
|
let int_of_field s =
|
|
match int_of_string (String.trim s) with
|
|
| exception Failure _ -> None
|
|
| x -> if x <> 0 then Some x else None
|
|
|
|
let reconstitute_date_dmy2 conf var =
|
|
let m =
|
|
let m = get var "ormonth" conf.env in
|
|
match String.uppercase_ascii m with
|
|
| "VD" -> Some 1
|
|
| "BR" -> Some 2
|
|
| "FM" -> Some 3
|
|
| "NI" -> Some 4
|
|
| "PL" -> Some 5
|
|
| "VT" -> Some 6
|
|
| "GE" -> Some 7
|
|
| "FL" -> Some 8
|
|
| "PR" -> Some 9
|
|
| "ME" -> Some 10
|
|
| "TH" -> Some 11
|
|
| "FT" -> Some 12
|
|
| "JC" -> Some 13
|
|
| _ -> int_of_field m
|
|
in
|
|
match get_number var "oryear" conf.env with
|
|
| Some y -> (
|
|
match m with
|
|
| Some m -> (
|
|
match get_number var "orday" conf.env with
|
|
| Some d ->
|
|
let dmy2 = { day2 = d; month2 = m; year2 = y; delta2 = 0 } in
|
|
if
|
|
dmy2.day2 >= 1 && dmy2.day2 <= 31 && dmy2.month2 >= 1
|
|
&& dmy2.month2 <= 13
|
|
then dmy2
|
|
else
|
|
let d = Date.dmy_of_dmy2 dmy2 in
|
|
bad_date conf d
|
|
| None ->
|
|
let dmy2 = { day2 = 0; month2 = m; year2 = y; delta2 = 0 } in
|
|
if dmy2.month2 >= 1 && dmy2.month2 <= 13 then dmy2
|
|
else
|
|
let d = Date.dmy_of_dmy2 dmy2 in
|
|
bad_date conf d)
|
|
| None -> { day2 = 0; month2 = 0; year2 = y; delta2 = 0 })
|
|
| None -> raise @@ ModErr (UERR_missing_field (Adef.safe "oryear"))
|
|
|
|
let reconstitute_date_dmy conf var =
|
|
let prec, y =
|
|
let y = get var "yyyy" conf.env in
|
|
let prec = p_getenv conf.env (var ^ "_prec") in
|
|
let len = String.length y in
|
|
if len > 1 then
|
|
match (y.[0], y.[len - 1]) with
|
|
| '?', _ -> (Some "maybe", String.sub y 1 (len - 1))
|
|
| '~', _ -> (Some "about", String.sub y 1 (len - 1))
|
|
| '/', '/' -> (Some "about", String.sub y 1 (len - 2))
|
|
| '<', _ | '/', _ -> (Some "before", String.sub y 1 (len - 1))
|
|
| '>', _ -> (Some "after", String.sub y 1 (len - 1))
|
|
| _, '/' -> (Some "after", String.sub y 0 (len - 1))
|
|
| _ -> (prec, y)
|
|
else (prec, y)
|
|
in
|
|
let force_f_cal, m =
|
|
let m = get var "mm" conf.env in
|
|
match String.uppercase_ascii m with
|
|
| "VD" -> (true, Some 1)
|
|
| "BR" -> (true, Some 2)
|
|
| "FM" -> (true, Some 3)
|
|
| "NI" -> (true, Some 4)
|
|
| "PL" -> (true, Some 5)
|
|
| "VT" -> (true, Some 6)
|
|
| "GE" -> (true, Some 7)
|
|
| "FL" -> (true, Some 8)
|
|
| "PR" -> (true, Some 9)
|
|
| "ME" -> (true, Some 10)
|
|
| "TH" -> (true, Some 11)
|
|
| "FT" -> (true, Some 12)
|
|
| "JC" -> (true, Some 13)
|
|
| _ -> (false, int_of_field m)
|
|
in
|
|
let d =
|
|
match int_of_field y with
|
|
| Some y -> (
|
|
let prec =
|
|
match prec with
|
|
| Some "about" -> About
|
|
| Some "maybe" -> Maybe
|
|
| Some "before" -> Before
|
|
| Some "after" -> After
|
|
| Some "oryear" -> (
|
|
match get_number var "oryear" conf.env with
|
|
| Some _ ->
|
|
let dmy2 = reconstitute_date_dmy2 conf var in
|
|
OrYear dmy2
|
|
| None -> Sure)
|
|
| Some "yearint" -> (
|
|
match get_number var "oryear" conf.env with
|
|
| Some _ ->
|
|
let dmy2 = reconstitute_date_dmy2 conf var in
|
|
YearInt dmy2
|
|
| None -> Sure)
|
|
| Some _ | None -> Sure
|
|
in
|
|
match m with
|
|
| Some m -> (
|
|
match get_number var "dd" conf.env with
|
|
| Some d ->
|
|
let d = { day = d; month = m; year = y; prec; delta = 0 } in
|
|
if d.day >= 1 && d.day <= 31 && d.month >= 1 && d.month <= 13
|
|
then Some d
|
|
else bad_date conf d
|
|
| None ->
|
|
let d = { day = 0; month = m; year = y; prec; delta = 0 } in
|
|
if d.month >= 1 && d.month <= 13 then Some d
|
|
else bad_date conf d)
|
|
| None -> Some { day = 0; month = 0; year = y; prec; delta = 0 })
|
|
| None -> None
|
|
in
|
|
(d, force_f_cal)
|
|
|
|
let check_missing_name base p =
|
|
let quest f g =
|
|
(* only raise error if `?` is not already recorded in the database *)
|
|
f = "?" && p.key_index <> dummy_iper
|
|
&& poi base p.key_index |> g |> sou base |> ( <> ) "?"
|
|
in
|
|
if p.first_name = "" || quest p.first_name get_first_name then
|
|
Some (UERR_missing_first_name (Adef.safe ""))
|
|
else if p.surname = "" || quest p.surname get_surname then
|
|
Some (UERR_missing_surname (Adef.safe ""))
|
|
else None
|
|
|
|
let check_missing_witnesses_names conf get list =
|
|
let aux witnesses =
|
|
let len = Array.length witnesses in
|
|
let rec loop i =
|
|
if i = len then None
|
|
else
|
|
let (fn, sn, _, _, _), _ = Array.get witnesses i in
|
|
if fn = "" && sn = "" then loop (i + 1)
|
|
else if fn = "" || fn = "?" then
|
|
Some
|
|
(UERR_missing_first_name
|
|
(transl_nth conf "witness/witnesses" 0 |> Adef.safe))
|
|
else if sn = "" || sn = "?" then
|
|
Some
|
|
(UERR_missing_surname
|
|
(transl_nth conf "witness/witnesses" 0 |> Adef.safe))
|
|
else loop (i + 1)
|
|
in
|
|
loop 0
|
|
in
|
|
let rec loop = function
|
|
| [] -> None
|
|
| hd :: tl -> (
|
|
match aux (get hd) with Some err -> Some err | None -> loop tl)
|
|
in
|
|
loop list
|
|
|
|
let check_greg_day conf d =
|
|
if d.day > Date.nb_days_in_month d.month d.year then bad_date conf d
|
|
|
|
let reconstitute_date conf var =
|
|
match reconstitute_date_dmy conf var with
|
|
| Some d, false ->
|
|
let d, cal =
|
|
match p_getenv conf.env (var ^ "_cal") with
|
|
| Some "G" | None ->
|
|
check_greg_day conf d;
|
|
(d, Dgregorian)
|
|
| Some "J" -> (Calendar.gregorian_of_julian d, Djulian)
|
|
| Some "F" -> (Calendar.gregorian_of_french d, Dfrench)
|
|
| Some "H" -> (Calendar.gregorian_of_hebrew d, Dhebrew)
|
|
| _ -> (d, Dgregorian)
|
|
in
|
|
Some (Dgreg (d, cal))
|
|
| Some d, true -> Some (Dgreg (Calendar.gregorian_of_french d, Dfrench))
|
|
| None, _ -> (
|
|
match p_getenv conf.env (var ^ "_text") with
|
|
| Some _ ->
|
|
let txt = only_printable (get var "text" conf.env) in
|
|
if txt = "" then None else Some (Dtext txt)
|
|
| None -> None)
|
|
|
|
let print_create_conflict conf base p var =
|
|
let err = UERR_already_defined (base, p, var) in
|
|
prerr conf err @@ fun () ->
|
|
print_error conf err;
|
|
let free_n =
|
|
Gutil.find_free_occ base (p_first_name base p) (p_surname base p)
|
|
in
|
|
Output.print_sstring conf {|<form method="post" action="|};
|
|
Output.print_sstring conf conf.command;
|
|
Output.print_sstring conf {|">|};
|
|
let aux =
|
|
List.iter (fun (x, v) ->
|
|
if x = "notes" || is_label_note x then Util.hidden_textarea conf x v
|
|
else Util.hidden_input conf x v)
|
|
in
|
|
aux conf.henv;
|
|
aux conf.env;
|
|
if var <> "" then Util.hidden_input conf "field" (Mutil.encode var);
|
|
Util.hidden_input conf "free_occ" (Mutil.encode @@ string_of_int free_n);
|
|
Output.print_sstring conf "<ul><li>";
|
|
transl conf "first free number"
|
|
|> Utf8.capitalize_fst |> Output.print_sstring conf;
|
|
Output.print_sstring conf (transl conf ":");
|
|
Output.print_sstring conf " ";
|
|
Output.print_sstring conf (string_of_int free_n);
|
|
Output.print_sstring conf ".\n";
|
|
Output.printf conf
|
|
(fcapitale (ftransl conf {|click on "%s"|}))
|
|
(transl conf "create");
|
|
Output.print_sstring conf " ";
|
|
Output.print_sstring conf (transl conf "to try again with this number");
|
|
Output.print_sstring conf ".</li><li>";
|
|
Output.print_sstring conf (Utf8.capitalize_fst (transl conf "or"));
|
|
Output.print_sstring conf " ";
|
|
Output.printf conf (ftransl conf {|click on "%s"|}) (transl conf "back");
|
|
Output.print_sstring conf " ";
|
|
Output.print_sstring conf (transl_nth conf "and" 0);
|
|
Output.print_sstring conf " ";
|
|
Output.print_sstring conf (transl conf "change it (the number) yourself");
|
|
Output.print_sstring conf ".</li><li>";
|
|
Output.print_sstring conf (Utf8.capitalize_fst (transl conf "or"));
|
|
Output.print_sstring conf " ";
|
|
Output.printf conf (ftransl conf {|click on "%s"|}) (transl conf "back");
|
|
Output.print_sstring conf " ";
|
|
Output.print_sstring conf (transl_nth conf "and" 0);
|
|
Output.print_sstring conf " ";
|
|
Output.print_sstring conf (transl conf {|use "link" instead of "create"|});
|
|
Output.print_sstring conf ".</li></ul>";
|
|
transl conf "create" |> Utf8.capitalize_fst |> Adef.encoded
|
|
|> Util.submit_input conf "create";
|
|
transl conf "back" |> Utf8.capitalize_fst |> Adef.encoded
|
|
|> Util.submit_input conf "return";
|
|
Output.print_sstring conf {|</form>|};
|
|
print_same_name conf base p
|
|
|
|
let insert_person conf base src new_persons (f, s, o, create, var) =
|
|
let f = if f = "" then "?" else f in
|
|
let s = if s = "" then "?" else s in
|
|
match create with
|
|
| Create (sex, info) -> (
|
|
try
|
|
if f = "?" || s = "?" then
|
|
if o <= 0 || o >= nb_of_persons base then raise Not_found
|
|
else
|
|
(* FIXME: this would fail if internal repr of iper is not int *)
|
|
let ip = Gwdb.iper_of_string @@ string_of_int o in
|
|
let p = poi base ip in
|
|
if p_first_name base p = f && p_surname base p = s then ip
|
|
else raise Not_found
|
|
else
|
|
match person_of_key base f s o with
|
|
| Some ip -> print_create_conflict conf base (poi base ip) var
|
|
| None -> raise Not_found
|
|
with Not_found ->
|
|
let o = if f = "?" || s = "?" then 0 else o in
|
|
let empty_string = Gwdb.empty_string in
|
|
let birth, birth_place, baptism, baptism_place =
|
|
match info with
|
|
| Some { ci_birth_date = b; ci_birth_place = bpl } ->
|
|
if String.length bpl >= 2 && String.sub bpl 0 2 = "b/" then
|
|
(None, "", b, String.sub bpl 2 (String.length bpl - 2))
|
|
else (b, bpl, None, "")
|
|
| None -> (None, "", None, "")
|
|
in
|
|
let death, death_place =
|
|
match info with
|
|
| Some { ci_death_date = Some d; ci_death_place = dpl } ->
|
|
(Death (Unspecified, Date.cdate_of_date d), dpl)
|
|
| Some { ci_death_date = None; ci_death_place = dpl } when dpl <> ""
|
|
->
|
|
(DeadDontKnowWhen, dpl)
|
|
| Some
|
|
{
|
|
ci_death = (DeadDontKnowWhen | NotDead) as dead;
|
|
ci_death_date = None;
|
|
ci_death_place = dpl;
|
|
} ->
|
|
(dead, dpl)
|
|
| Some { ci_death = OfCourseDead } -> (OfCourseDead, "")
|
|
| Some _ | None -> (infer_death_bb conf birth baptism, "")
|
|
in
|
|
let occupation =
|
|
match info with
|
|
| Some { ci_occupation = occupation } -> occupation
|
|
| None -> ""
|
|
in
|
|
let access =
|
|
match info with
|
|
| Some { ci_public = p } -> if p then Public else IfTitles
|
|
| None -> IfTitles
|
|
in
|
|
let p =
|
|
{
|
|
first_name = Gwdb.insert_string base f;
|
|
surname = Gwdb.insert_string base s;
|
|
occ = o;
|
|
image = empty_string;
|
|
first_names_aliases = [];
|
|
surnames_aliases = [];
|
|
public_name = empty_string;
|
|
qualifiers = [];
|
|
aliases = [];
|
|
titles = [];
|
|
rparents = [];
|
|
related = [];
|
|
occupation = Gwdb.insert_string base occupation;
|
|
sex;
|
|
access;
|
|
birth = Date.cdate_of_od birth;
|
|
birth_place = Gwdb.insert_string base birth_place;
|
|
birth_note = empty_string;
|
|
birth_src = empty_string;
|
|
baptism = Date.cdate_of_od baptism;
|
|
baptism_place = Gwdb.insert_string base baptism_place;
|
|
baptism_note = empty_string;
|
|
baptism_src = empty_string;
|
|
death;
|
|
death_place = Gwdb.insert_string base death_place;
|
|
death_note = empty_string;
|
|
death_src = empty_string;
|
|
burial = UnknownBurial;
|
|
burial_place = empty_string;
|
|
burial_note = empty_string;
|
|
burial_src = empty_string;
|
|
pevents = [];
|
|
notes = empty_string;
|
|
psources = Gwdb.insert_string base (only_printable src);
|
|
key_index = Gwdb.dummy_iper;
|
|
}
|
|
in
|
|
let a = no_ascend in
|
|
let u = no_union in
|
|
let ip = insert_person base p a u in
|
|
if f <> "?" && s <> "?" then
|
|
new_persons := { p with key_index = ip } :: !new_persons;
|
|
ip)
|
|
| Link -> (
|
|
if f = "?" || s = "?" then
|
|
if o < 0 || o >= nb_of_persons base then print_err_unknown conf (f, s, o)
|
|
else
|
|
(* FIXME: this would fail if internal repr of iper is not int *)
|
|
let ip = Gwdb.iper_of_string @@ string_of_int o in
|
|
let p = poi base ip in
|
|
if p_first_name base p = f && p_surname base p = s then ip
|
|
else print_err_unknown conf (f, s, o)
|
|
else
|
|
match person_of_key base f s o with
|
|
| Some ip -> ip
|
|
| None -> print_err_unknown conf (f, s, o))
|
|
|
|
let rec update_conf_env field (p : Adef.encoded_string)
|
|
(occ : Adef.encoded_string) o_env n_env =
|
|
match o_env with
|
|
| [] -> n_env
|
|
| ((name, _) as head) :: rest ->
|
|
if name = field ^ "p" then
|
|
update_conf_env field p occ rest ((name, p) :: n_env)
|
|
else if name = field ^ "occ" then
|
|
update_conf_env field p occ rest ((name, occ) :: n_env)
|
|
else if
|
|
name = "link" || name = "create" || name = "free_occ" || name = "field"
|
|
|| name = "link_occ"
|
|
then update_conf_env field p occ rest n_env
|
|
else update_conf_env field p occ rest (head :: n_env)
|
|
|
|
let update_conf_aux _create _occ conf =
|
|
let field =
|
|
match p_getenv conf.env "field" with Some f -> f ^ "_" | None -> ""
|
|
in
|
|
let occ =
|
|
match p_getenv conf.env _occ with
|
|
| Some occ -> Mutil.encode occ
|
|
| None -> Adef.encoded ""
|
|
in
|
|
{ conf with env = update_conf_env field _create occ conf.env [] }
|
|
|
|
let update_conf_create = update_conf_aux (Adef.encoded "create") "free_occ"
|
|
let update_conf_link = update_conf_aux (Adef.encoded "link") "link_occ"
|
|
|
|
let update_conf conf =
|
|
match p_getenv conf.env "link" with
|
|
| Some _ -> update_conf_link conf
|
|
| None -> (
|
|
match p_getenv conf.env "create" with
|
|
| Some _ -> update_conf_create conf
|
|
| None -> conf)
|
|
|
|
let rec list_except x = function
|
|
| y :: l -> if x = y then l else y :: list_except x l
|
|
| [] -> invalid_arg "list_except"
|
|
|
|
let update_related_pointers base pi ol nl =
|
|
let ol = List.sort compare ol in
|
|
let nl = List.sort compare nl in
|
|
let added_rel, removed_rel =
|
|
let rec loop (added_rel, removed_rel) ol nl =
|
|
match (ol, nl) with
|
|
| oip :: orl, nip :: nrl ->
|
|
if oip < nip then loop (added_rel, oip :: removed_rel) orl nl
|
|
else if oip > nip then loop (nip :: added_rel, removed_rel) ol nrl
|
|
else loop (added_rel, removed_rel) orl nrl
|
|
| [], _ -> (nl @ added_rel, removed_rel)
|
|
| _, [] -> (added_rel, ol @ removed_rel)
|
|
in
|
|
loop ([], []) ol nl
|
|
in
|
|
List.iter
|
|
(fun ip ->
|
|
let p = gen_person_of_person (poi base ip) in
|
|
patch_person base ip { p with related = pi :: p.related })
|
|
added_rel;
|
|
List.iter
|
|
(fun ip ->
|
|
let p = gen_person_of_person (poi base ip) in
|
|
let related =
|
|
if List.mem pi p.related then list_except pi p.related
|
|
else (
|
|
Printf.eprintf "Warning: related pointer was missing\n";
|
|
flush stderr;
|
|
p.related)
|
|
in
|
|
patch_person base ip { p with related })
|
|
removed_rel
|