Uzurka/Geneweb
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial comit - Clone

Browse Source
This commit is contained in:
Uzurka
2024-03-05 22:01:20 +01:00
commit 385cf8e5aa
727 changed files with 164567 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

178
lib/GWPARAM.ml Normal file
View File

@@ -0,0 +1,178 @@
(** This module allows plugins to modify geneweb configuration.
This approch is preffered to Functors or library variants
for simple functions if it does not come with a performance cost.
*)
let nb_errors = ref 0
let errors_undef = ref []
let errors_other = ref []
let set_vars = ref []
let gwd_cmd = ref ""
type syslog_level =
[ `LOG_ALERT
| `LOG_CRIT
| `LOG_DEBUG
| `LOG_EMERG
| `LOG_ERR
| `LOG_INFO
| `LOG_NOTICE
| `LOG_WARNING ]
module Default = struct
let init () = Secure.add_assets Filename.current_dir_name
let base_path pref bname =
List.fold_right Filename.concat (Secure.base_dir () :: pref) bname
let bpath bname = Filename.concat (Secure.base_dir ()) bname
(** [output_error ?headers ?content conf code]
Send the http status [code], [headers] and
[content] if provided, or default content otherwise.
*)
let output_error =
let output_file conf fn =
let ic = open_in fn in
try
in_channel_length ic |> really_input_string ic
|> Output.print_sstring conf;
close_in ic
with _ -> ( try close_in ic with _ -> ())
in
fun ?(headers = []) ?(content : Adef.safe_string option) conf code ->
Output.status conf code;
List.iter (Output.header conf "%s") headers;
Output.print_string conf (Adef.encoded "<h1>Incorrect request</h1>");
match content with
| Some content -> Output.print_string conf content
| None -> (
let code =
match code with
| Def.Bad_Request -> "400"
| Unauthorized -> "401"
| Forbidden -> "403"
| Not_Found -> "404"
| Conflict -> "409"
| Internal_Server_Error -> "500"
| Service_Unavailable -> "503"
| OK | Moved_Temporarily -> assert false
in
let fname lang =
code ^ "-" ^ lang ^ ".html"
|> Filename.concat "etc" |> Mutil.search_asset_opt
in
match fname conf.lang with
| Some fn -> output_file conf fn
| None -> (
match fname "en" with
| Some fn -> output_file conf fn
| None -> Output.print_sstring conf ""))
(** Calcul les droits de visualisation d'une personne en
fonction de son age.
Renvoie (dans l'ordre des tests) :
- Vrai si : magicien ou ami ou la personne est public
- Vrai si : la personne est en si_titre, si elle a au moins un
titre et que public_if_title = yes dans le fichier gwf
- Faux si : la personne n'est pas décédée et private_years > 0
- Vrai si : la personne est plus agée (en fonction de la date de
naissance ou de la date de baptème) que privates_years
- Faux si : la personne est plus jeune (en fonction de la date de
naissance ou de la date de baptème) que privates_years
- Vrai si : la personne est décédée depuis plus de privates_years
- Faux si : la personne est décédée depuis moins de privates_years
- Vrai si : la personne a entre 80 et 120 ans et qu'elle n'est pas
privée et public_if_no_date = yes
- Vrai si : la personne s'est mariée depuis plus de private_years
- Faux dans tous les autres cas *)
let p_auth conf base p =
conf.Config.wizard || conf.friend
|| Gwdb.get_access p = Public
|| conf.public_if_titles
&& Gwdb.get_access p = IfTitles
&& Gwdb.nobtitles base conf.allowed_titles conf.denied_titles p <> []
||
let death = Gwdb.get_death p in
if death = NotDead then conf.private_years < 1
else
let check_date d lim none =
match d with
| None -> none ()
| Some d ->
let a = Date.time_elapsed d conf.today in
if a.Def.year > lim then true
else if a.year < conf.private_years then false
else a.month > 0 || a.day > 0
in
check_date (Gwdb.get_birth p |> Date.cdate_to_dmy_opt) conf.private_years
@@ fun () ->
check_date
(Gwdb.get_baptism p |> Date.cdate_to_dmy_opt)
conf.private_years
@@ fun () ->
check_date
(Gwdb.get_death p |> Date.dmy_of_death)
conf.private_years_death
@@ fun () ->
(Gwdb.get_access p <> Def.Private && conf.public_if_no_date)
||
let families = Gwdb.get_family p in
let len = Array.length families in
let rec loop i =
i < len
&& check_date
(Array.get families i |> Gwdb.foi base |> Gwdb.get_marriage
|> Date.cdate_to_dmy_opt)
conf.private_years_marriage
(fun () -> loop (i + 1))
in
loop 0
let syslog (level : syslog_level) msg =
let tm = Unix.(time () |> localtime) in
let level =
match level with
| `LOG_EMERG -> "EMERGENCY"
| `LOG_ALERT -> "ALERT"
| `LOG_CRIT -> "CRITICAL"
| `LOG_ERR -> "ERROR"
| `LOG_WARNING -> "WARNING"
| `LOG_NOTICE -> "NOTICE"
| `LOG_INFO -> "INFO"
| `LOG_DEBUG -> "DEBUG"
in
Printf.eprintf "[%s]: %s %s\n"
(Mutil.sprintf_date tm : Adef.safe_string :> string)
level msg
let wrap_output (conf : Config.config) (title : Adef.safe_string)
(content : unit -> unit) =
Output.print_sstring conf {|<!DOCTYPE html><head><title>|};
Output.print_string conf title;
Output.print_sstring conf {|</title>|};
Output.print_sstring conf {|<meta name="robots" content="none">|};
Output.print_sstring conf {|<meta charset="|};
Output.print_sstring conf conf.charset;
Output.print_sstring conf {|">|};
Output.print_sstring conf
{|<meta name="viewport" content="width=device-width, initial-scale=1, shrink-to-fit=no">|};
Output.print_sstring conf {|</head>|};
Output.print_sstring conf "<body>";
content ();
Output.print_sstring conf {|</body></html>|}
end
let init = ref Default.init
let base_path = ref Default.base_path
let bpath = ref Default.bpath
let output_error = ref Default.output_error
let p_auth = ref Default.p_auth
let syslog = ref Default.syslog
(** [wrap_output conf title content]
Plugins defining a page content but not a complete UI
may want to wrap their page using [wrap_output].
*)
let wrap_output = ref Default.wrap_output

110
lib/GWPARAM.mli Normal file
View File

@@ -0,0 +1,110 @@
val nb_errors : int ref
val errors_undef : string list ref
val errors_other : string list ref
val set_vars : string list ref
val gwd_cmd : string ref
type syslog_level =
[ `LOG_EMERG (** A panic condition. *)
| `LOG_ALERT
(** A condition that should be corrected immediately,
such as a corrupted system database. *)
| `LOG_CRIT (** Critical conditions, such as hard device errors. *)
| `LOG_ERR (** Errors. *)
| `LOG_WARNING (** Warning messages. *)
| `LOG_DEBUG
(** Conditions that are not error conditions,
but that may require special handling. *)
| `LOG_INFO (** Informational messages. *)
| `LOG_NOTICE
(** Messages that contain information
normally of use only when debugging a program. *)
]
(** The level of log gravity. See SYSLOG(3) *)
(* S: Move it to gwd_lib? *)
val init : (unit -> unit) ref
(** Function called before gwd starts
e.g. inititialise assets folders in Secure module. *)
val base_path : (string list -> string -> string) ref
(** [!base_path pref fname] function that returns a path to a file identified by [pref] [fname]
related to bases. [pref] is like a category for file [fname].
See {!val:GWPARAM.Default.base_path} for a concrete example.
*)
val bpath : (string -> string) ref
(** Same as {!val:base_path}, but without the prefix (avoid unecessary empty list). *)
val output_error :
(?headers:string list ->
?content:Adef.safe_string ->
Config.config ->
Def.httpStatus ->
unit)
ref
(** [!output_error ?headers ?content conf status] default function that send the http status [status].
Also send [headers] and use [content] (typically a HTML string describing the error) if provided.
*)
val p_auth : (Config.config -> Gwdb.base -> Gwdb.person -> bool) ref
(** Check if a person should be displayed or not *)
val syslog : (syslog_level -> string -> unit) ref
(** [!syslog level log] log message [log] with gravity level [level] on stderr. *)
val wrap_output :
(Config.config -> Adef.safe_string -> (unit -> unit) -> unit) ref
(** [wrap_output conf title content]
Wrap the display of [title] and [content] in a defined template.
*)
module Default : sig
val init : unit -> unit
(** Inititialise assets directories for gwd server:
* current directory
*)
val base_path : string list -> string -> string
(** Use concatenation of [Secure.base_dir ()], [pref] and [fname] *)
val bpath : string -> string
(** [Filename.concat (Secure.base_dir ())] *)
val output_error :
?headers:string list ->
?content:Adef.safe_string ->
Config.config ->
Def.httpStatus ->
unit
(** If [?content] is not set, sends page content from {/etc/<status-code>-<lang>.html}.
If the current lang is not available, use `en` *)
val p_auth : Config.config -> Gwdb.base -> Gwdb.person -> bool
(** Calculate the access rights to the person's information in
according to his age.
Returns (in the order of the tests) :
- `true` if requester is wizard or friend or person is public
- `true` if person has at least one title and {i public_if_title}
is set to {i yes} in gwf config file
- `false` if person is alive and {i private_years} > 0
- `true` if person is older (depending on the date of
birth or baptism date) then {i privates_years}
- `false` if person is younger (depending on the date of
birth or baptism date) then {i privates_years}
- `true` if person has been deceased for more than {i privates_years}
- `false` if person has been deceased for less than {i privates_years}
- `true` if person is between 80 and 120 years old and he is not beeing
private and {i public_if_no_date} is set to {i yes} in gwf config file
- `true` if person has been married for more than {i private_years}
- `false` otherwise
*)
val syslog : syslog_level -> string -> unit
(** Prints on stderr using `"[date]: level message"` format. *)
val wrap_output : Config.config -> Adef.safe_string -> (unit -> unit) -> unit
(** Display in a very basic HTML doc, with no CSS or JavaScript. *)
end

43
lib/GWPARAM_ITL.ml Normal file
View File

@@ -0,0 +1,43 @@
module Default = struct
let init_cache _conf _base _ip _nb_asc _from_gen_desc _nb_desc = ()
let max_ancestor_level _conf _base _ip _bname _max start = start
let max_descendant_level _conf _base _ip _max = 0
let tree_generation_list _conf _base _bname _p = (None, None)
let get_father _conf _base _bsrc _ip = None
let get_mother _conf _base _bsrc _ip = None
let get_person _conf _base _bsrc _ip = None
let get_father' _conf _base _ip = None
let get_mother' _conf _base _ip = None
let get_family _conf _base _base_prefix _p _ifam = assert false
let get_families _conf _base _ip = []
let get_children_of_parents _base _baseprefix _ifam _ifath _imoth = []
let get_children _base _baseprefix _ifam _ifath _imoth = []
let get_children' _base _baseprefix _ifam _ifath _imoth = []
let has_children _conf _base _p _fam = false
let has_family_correspondance _baseprefix _ip = false
let has_parents_link _baseprefix _ip = false
let has_siblings _baseprefix _ip = false
let nb_children _baseprefix _ifam = 0
let nb_families _baseprefix _ip = 0
end
let init_cache = ref Default.init_cache
let max_ancestor_level = ref Default.max_ancestor_level
let max_descendant_level = ref Default.max_descendant_level
let tree_generation_list = ref Default.tree_generation_list
let get_father = ref Default.get_father
let get_mother = ref Default.get_mother
let get_person = ref Default.get_person
let get_father' = ref Default.get_father'
let get_mother' = ref Default.get_mother'
let get_family = ref Default.get_family
let get_families = ref Default.get_families
let get_children_of_parents = ref Default.get_children_of_parents
let has_children = ref Default.has_children
let get_children = ref Default.get_children
let get_children' = ref Default.get_children'
let has_family_correspondance = ref Default.has_family_correspondance
let has_parents_link = ref Default.has_parents_link
let has_siblings = ref Default.has_siblings
let nb_children = ref Default.nb_children
let nb_families = ref Default.nb_families

126
lib/GWPARAM_ITL.mli Normal file
View File

@@ -0,0 +1,126 @@
val init_cache :
(Config.config -> Gwdb.base -> Gwdb.iper -> int -> int -> int -> unit) ref
(** [init_cache conf base ip nb_asc from_gen_desc nb_desc] *)
val max_ancestor_level :
(Config.config -> Gwdb.base -> Gwdb.iper -> string -> int -> int -> int) ref
val max_descendant_level :
(Config.config -> Gwdb.base -> Gwdb.iper -> int -> int) ref
val tree_generation_list :
(Config.config ->
Gwdb.base ->
string ->
Gwdb.person ->
(Gwdb.person * Gwdb.ifam * string) option
* (Gwdb.person * Gwdb.ifam * string) option)
ref
val get_father :
(Config.config ->
Gwdb.base ->
string ->
Gwdb.iper ->
((Gwdb.person * bool) * string) option)
ref
val get_mother :
(Config.config ->
Gwdb.base ->
string ->
Gwdb.iper ->
((Gwdb.person * bool) * string) option)
ref
val get_person :
(Config.config ->
Gwdb.base ->
string ->
Gwdb.iper ->
((Gwdb.person * bool) * string) option)
ref
val get_father' :
(Config.config ->
Gwdb.base ->
Gwdb.iper ->
(string
* (Gwdb.person * bool)
* Gwdb.ifam
* Gwdb.family
* (Gwdb.iper * Gwdb.iper * Gwdb.iper))
option)
ref
val get_mother' :
(Config.config ->
Gwdb.base ->
Gwdb.iper ->
(string
* (Gwdb.person * bool)
* Gwdb.ifam
* Gwdb.family
* (Gwdb.iper * Gwdb.iper * Gwdb.iper))
option)
ref
val get_family :
(Config.config ->
Gwdb.base ->
string ->
Gwdb.person ->
Gwdb.ifam ->
(Gwdb.family * (Gwdb.iper * Gwdb.iper * Gwdb.iper) * bool) option)
ref
val get_families :
(Config.config ->
Gwdb.base ->
Gwdb.person ->
(Gwdb.ifam
* Gwdb.family
* (Gwdb.iper * Gwdb.iper * Gwdb.person)
* string
* bool)
list)
ref
val get_children_of_parents :
(Gwdb.base ->
string ->
Gwdb.ifam ->
Gwdb.iper ->
Gwdb.iper ->
(Gwdb.person * string) list)
ref
val get_children :
(Gwdb.base ->
string ->
Gwdb.ifam ->
Gwdb.iper ->
Gwdb.iper ->
((Gwdb.person * bool) * string) list)
ref
val get_children' :
(Config.config ->
Gwdb.base ->
Gwdb.iper ->
Gwdb.family ->
Gwdb.iper ->
(string
* (Gwdb.iper * Gwdb.iper * Gwdb.iper)
* ((Gwdb.person * bool) * string * bool) list)
list)
ref
val has_children :
(Config.config -> Gwdb.base -> Gwdb.person -> Gwdb.family -> bool) ref
val has_family_correspondance : (string -> Gwdb.iper -> bool) ref
val has_parents_link : (string -> Gwdb.iper -> bool) ref
val has_siblings : (string -> Gwdb.iper -> bool) ref
val nb_children : (string -> Gwdb.ifam -> int) ref
val nb_families : (string -> Gwdb.iper -> int) ref

620
lib/advSearchOk.ml Normal file
View File

@@ -0,0 +1,620 @@
(* Copyright (c) 1998-2007 INRIA *)
open Config
open Def
open Gwdb
open Util
let get_number var key env = p_getint env (var ^ "_" ^ key)
let reconstitute_date_dmy conf var =
match get_number var "yyyy" conf.env with
| Some y -> (
match get_number var "mm" conf.env with
| Some m -> (
match get_number var "dd" conf.env with
| Some d ->
if d >= 1 && d <= 31 && m >= 1 && m <= 12 then
Some { day = d; month = m; year = y; prec = Sure; delta = 0 }
else None
| None ->
if m >= 1 && m <= 12 then
Some { day = 0; month = m; year = y; prec = Sure; delta = 0 }
else None)
| None -> Some { day = 0; month = 0; year = y; prec = Sure; delta = 0 })
| None -> None
let reconstitute_date conf var =
match reconstitute_date_dmy conf var with
| Some d -> Some (Dgreg (d, Dgregorian))
| None -> None
let rec skip_spaces x i =
if i = String.length x then i
else if String.unsafe_get x i = ' ' then skip_spaces x (i + 1)
else i
let rec skip_no_spaces x i =
if i = String.length x then i
else if String.unsafe_get x i != ' ' then skip_no_spaces x (i + 1)
else i
let string_incl x y =
let rec loop j_ini =
if j_ini = String.length y then false
else
let rec loop1 i j =
if i = String.length x then
if j = String.length y then true
else String.unsafe_get y j = ' ' || String.unsafe_get y (j - 1) = ' '
else if
j < String.length y && String.unsafe_get x i = String.unsafe_get y j
then loop1 (i + 1) (j + 1)
else loop (skip_spaces y (skip_no_spaces y j_ini))
in
loop1 0 j_ini
in
loop 0
let abbrev_lower x = Name.abbrev (Name.lower x)
(* Get the field name of an event criteria depending of the search type. *)
let get_event_field_name gets event_criteria event_name search_type =
if search_type <> "OR" then event_name ^ "_" ^ event_criteria
else if "on" = gets ("event_" ^ event_name) then event_criteria
else ""
(*
Search for other persons in the base matching with the provided infos.
On search semantic:
Search can be set to be exact on the first name and/or the surname,
if no first name or surname is provided then the search ignores the
parameter in both the exact and the loose case.
- When search is loose it is only necessary for each name atom (name atoms
for "Jean-Pierre" are: [Jean] [Pierre]) to be found at least once in another
person's name atoms in the base.
- When search is exact, it is necessary for each atom to be found exactly the
number of times it occurs in the given name but order is not considered for
a person from the base to match. (ie. "Pierre-Jean de Bourbon de Vallois" matches
with "Jean Pierre de Vallois de Bourbon" but not with "Jean de Bourbon")
*)
let advanced_search conf base max_answers =
let hs = Hashtbl.create 73 in
let hss = Hashtbl.create 73 in
let hd = Hashtbl.create 73 in
let getd x =
try Hashtbl.find hd x
with Not_found ->
let v =
(reconstitute_date conf (x ^ "1"), reconstitute_date conf (x ^ "2"))
in
Hashtbl.add hd x v;
v
in
let gets x =
try Hashtbl.find hs x
with Not_found ->
let v = match p_getenv conf.env x with Some v -> v | None -> "" in
Hashtbl.add hs x v;
v
in
let getss x =
let y = gets x in
if y <> "" then [ y ]
else
match Hashtbl.find_opt hss @@ x with
| Some v -> v
| None ->
let rec loop acc i =
let k = x ^ "_" ^ string_of_int i in
match p_getenv conf.env k with
| Some v -> loop (if v <> "" then v :: acc else acc) (i + 1)
| None -> acc
in
let v = loop [] 1 in
Hashtbl.add hss x v;
v
in
let fn_list =
List.map
(fun s -> List.map Name.lower @@ Name.split_fname s)
(getss "first_name")
in
let sn_list =
List.map
(fun s -> List.map Name.lower @@ Name.split_sname s)
(getss "surname")
in
(* Search type can be AND or OR. *)
let search_type = gets "search_type" in
(* Return empty_field_value if the field is empty. Apply function cmp to the field value. Also check the authorization. *)
let apply_to_field_value_raw p x cmp empty_default_value =
let y = gets x in
if y = "" then empty_default_value
else if authorized_age conf base p then cmp y
else false
in
let apply_to_field_value p x get cmp empty_default_value =
let y = gets x in
if y = "" then empty_default_value
else if authorized_age conf base p then
cmp (abbrev_lower y) (abbrev_lower @@ sou base @@ get p)
else false
in
let do_compare p y get cmp =
let s = abbrev_lower @@ get p in
List.exists (fun s' -> cmp (abbrev_lower s') s) y
in
let apply_to_field_values_raw p x get cmp empty_default_value =
let y = getss x in
if y = [] then empty_default_value
else if authorized_age conf base p then do_compare p y get cmp
else false
in
let apply_to_field_values p x get cmp empty_default_value =
let get p = sou base @@ get p in
apply_to_field_values_raw p x get cmp empty_default_value
in
(* Check if the date matches with the person event. *)
let match_date p x df empty_default_value =
let d1, d2 = getd x in
authorized_age conf base p
&&
match (d1, d2) with
| Some (Dgreg (d1, _)), Some (Dgreg (d2, _)) -> (
match df () with
| Some (Dgreg (d, _)) ->
Date.compare_dmy d d1 >= 0 && Date.compare_dmy d d2 <= 0
| _ -> false)
| Some (Dgreg (d1, _)), _ -> (
match df () with
| Some (Dgreg (d, _)) -> Date.compare_dmy d d1 >= 0
| _ -> false)
| _, Some (Dgreg (d2, _)) -> (
match df () with
| Some (Dgreg (d, _)) -> Date.compare_dmy d d2 <= 0
| _ -> false)
| _ -> empty_default_value
in
let match_sex p empty_default_value =
apply_to_field_value_raw p "sex"
(function
| "M" -> get_sex p = Male | "F" -> get_sex p = Female | _ -> true)
empty_default_value
in
let bapt_date_field_name =
get_event_field_name gets "date" "bapt" search_type
in
let birth_date_field_name =
get_event_field_name gets "date" "birth" search_type
in
let death_date_field_name =
get_event_field_name gets "date" "death" search_type
in
let burial_date_field_name =
get_event_field_name gets "date" "burial" search_type
in
let marriage_date_field_name =
get_event_field_name gets "date" "marriage" search_type
in
let bapt_place_field_name =
get_event_field_name gets "place" "bapt" search_type
in
let birth_place_field_name =
get_event_field_name gets "place" "birth" search_type
in
let death_place_field_name =
get_event_field_name gets "place" "death" search_type
in
let burial_place_field_name =
get_event_field_name gets "place" "burial" search_type
in
let marriage_place_field_name =
get_event_field_name gets "place" "marriage" search_type
in
let match_baptism_date p empty_default_value =
match_date p bapt_date_field_name
(fun () -> Date.od_of_cdate (get_baptism p))
empty_default_value
in
let match_birth_date p empty_default_value =
match_date p birth_date_field_name
(fun () -> Date.od_of_cdate (get_birth p))
empty_default_value
in
let match_death_date p empty_default_value =
match_date p death_date_field_name
(fun () -> Date.date_of_death (get_death p))
empty_default_value
in
let match_burial_date p empty_default_value =
match_date p burial_date_field_name
(fun () ->
(* TODO Date.cdate_of_burial *)
match get_burial p with
| Buried cod | Cremated cod -> Date.od_of_cdate cod
| UnknownBurial -> None)
empty_default_value
in
let cmp_place = if "on" = gets "exact_place" then ( = ) else string_incl in
let match_baptism_place p empty_default_value =
apply_to_field_values p bapt_place_field_name get_baptism_place cmp_place
empty_default_value
in
let match_birth_place p empty_default_value =
apply_to_field_values p birth_place_field_name get_birth_place cmp_place
empty_default_value
in
let match_death_place p empty_default_value =
apply_to_field_values p death_place_field_name get_death_place cmp_place
empty_default_value
in
let match_burial_place p empty_default_value =
apply_to_field_values p burial_place_field_name get_burial_place cmp_place
empty_default_value
in
let match_occupation p empty_default_value =
apply_to_field_value p "occu" get_occupation string_incl empty_default_value
in
let match_name search_list exact : string list -> bool =
let eq : string list -> string list -> bool =
if exact then fun x search ->
List.sort compare search = List.sort compare x
else fun x search -> List.for_all (fun s -> List.mem s x) search
in
fun x -> List.exists (eq x) search_list
in
let match_first_name =
if fn_list = [] then fun _ -> true
else
let eq = match_name fn_list (gets "exact_first_name" = "on") in
fun p ->
eq
(List.map Name.lower @@ Name.split_fname @@ sou base
@@ get_first_name p)
in
let match_surname =
if sn_list = [] then fun _ -> true
else
let eq = match_name sn_list (gets "exact_surname" = "on") in
fun p ->
eq (List.map Name.lower @@ Name.split_sname @@ sou base @@ get_surname p)
in
let match_married p empty_default_value =
apply_to_field_value_raw p "married"
(function
| "Y" -> get_family p <> [||] | "N" -> get_family p = [||] | _ -> true)
empty_default_value
in
let match_marriage p x y empty_default_value =
let d1, d2 = getd x in
let y = getss y in
let test_date_place df =
Array.exists
(fun ifam ->
let fam = foi base ifam in
let sp = poi base @@ Gutil.spouse (get_iper p) fam in
if authorized_age conf base sp then
df fam
&& (y = []
|| do_compare fam y
(fun f -> sou base @@ get_marriage_place f)
cmp_place)
else false)
(get_family p)
in
match (d1, d2) with
| Some d1, Some d2 ->
test_date_place (fun fam ->
match Date.od_of_cdate (get_marriage fam) with
| Some (Dgreg (_, _) as d) ->
if Date.compare_date d d1 < 0 then false
else if Date.compare_date d2 d < 0 then false
else true
| _ -> false)
| Some d1, _ ->
test_date_place (fun fam ->
match Date.od_of_cdate (get_marriage fam) with
| Some (Dgreg (_, _) as d) when authorized_age conf base p ->
if Date.compare_date d d1 < 0 then false else true
| _ -> false)
| _, Some d2 ->
test_date_place (fun fam ->
match Date.od_of_cdate (get_marriage fam) with
| Some (Dgreg (_, _) as d) when authorized_age conf base p ->
if Date.compare_date d d2 > 0 then false else true
| _ -> false)
| _ ->
if y = [] then empty_default_value else test_date_place (fun _ -> true)
in
(* Check the civil status. The test is the same for an AND or a OR search request. *)
let match_civil_status ~skip_fname ~skip_sname p =
match_sex p true
&& (skip_fname || match_first_name p)
&& (skip_sname || match_surname p)
&& match_married p true && match_occupation p true
in
let match_person ?(skip_fname = false) ?(skip_sname = false)
((list, len) as acc) p search_type =
if search_type <> "OR" then
if
match_civil_status ~skip_fname ~skip_sname p
&& match_baptism_date p true && match_baptism_place p true
&& match_birth_date p true && match_birth_place p true
&& match_burial_date p true && match_burial_place p true
&& match_death_date p true && match_death_place p true
&& match_marriage p marriage_date_field_name marriage_place_field_name
true
then (p :: list, len + 1)
else acc
else if
match_civil_status ~skip_fname ~skip_sname p
&& (getss "place" = []
&& gets "date2_yyyy" = ""
&& gets "date1_yyyy" = ""
|| (match_baptism_date p false || match_baptism_place p false)
&& match_baptism_date p true && match_baptism_place p true
|| (match_birth_date p false || match_birth_place p false)
&& match_birth_date p true && match_birth_place p true
|| (match_burial_date p false || match_burial_place p false)
&& match_burial_date p true && match_burial_place p true
|| (match_death_date p false || match_death_place p false)
&& match_death_date p true && match_death_place p true
|| match_marriage p marriage_date_field_name marriage_place_field_name
false)
then (p :: list, len + 1)
else acc
in
let list, len =
if "on" = gets "sosa_filter" then
match Util.find_sosa_ref conf base with
| Some sosa_ref ->
let rec loop p (set, acc) =
if not (IperSet.mem (get_iper p) set) then
let set = IperSet.add (get_iper p) set in
let acc = match_person acc p search_type in
match get_parents p with
| Some ifam ->
let fam = foi base ifam in
let set, acc =
loop (pget conf base @@ get_mother fam) (set, acc)
in
loop (pget conf base @@ get_father fam) (set, acc)
| None -> (set, acc)
else (set, acc)
in
loop (pget conf base @@ get_iper sosa_ref) (IperSet.empty, ([], 0))
|> snd
| None -> ([], 0)
else if fn_list <> [] || sn_list <> [] then
let list_aux strings_of persons_of split n_list exact =
List.map
(List.map (fun x ->
let eq = match_name n_list exact in
let istrs = strings_of base x in
List.fold_left
(fun acc istr ->
let str = Mutil.nominative (sou base istr) in
if eq (List.map Name.lower @@ split str) then istr :: acc
else acc)
[] istrs))
n_list
|> List.flatten |> List.flatten |> List.sort_uniq compare
|> List.map (spi_find @@ persons_of base)
|> List.flatten |> List.sort_uniq compare
in
let skip_fname, skip_sname, list =
if sn_list <> [] then
( false,
true,
list_aux Gwdb.base_strings_of_surname Gwdb.persons_of_surname
Name.split_sname sn_list
(gets "exact_surname" = "on") )
else
( true,
false,
list_aux Gwdb.base_strings_of_first_name Gwdb.persons_of_first_name
Name.split_fname fn_list
(gets "exact_first_name" = "on") )
in
let rec loop ((_, len) as acc) = function
| [] -> acc
| _ when len > max_answers -> acc
| ip :: l ->
loop
(match_person ~skip_fname ~skip_sname acc (pget conf base ip)
search_type)
l
in
loop ([], 0) list
else
Gwdb.Collection.fold_until
(fun (_, len) -> len <= max_answers)
(fun acc i -> match_person acc (pget conf base i) search_type)
([], 0) (Gwdb.ipers base)
in
(List.rev list, len)
let searching_fields conf base =
let test_date x =
reconstitute_date conf (x ^ "1") <> None
|| reconstitute_date conf (x ^ "2") <> None
in
let gets x =
match p_getenv conf.env x with
| Some v when v <> "" -> v
| _ ->
let rec loop acc i =
let k = x ^ "_" ^ string_of_int i in
match p_getenv conf.env k with
| Some v ->
loop
(if acc = "" then v
else if v = "" then acc
else acc ^ " / " ^ v)
(i + 1)
| None -> acc
in
loop "" 1
in
let test_string x = gets x <> "" in
let getd x =
(reconstitute_date conf (x ^ "1"), reconstitute_date conf (x ^ "2"))
in
let sex = match gets "sex" with "M" -> 0 | "F" -> 1 | _ -> 2 in
(* Fonction pour tester un simple champ texte (e.g: first_name). *)
let string_field x (search : Adef.safe_string) =
if test_string x then
search ^^^ " " ^<^ (escape_html (gets x) :> Adef.safe_string)
else search
in
(* Returns the place and date request. (e.g.: ...in Paris between 1800 and 1900) *)
let get_place_date_request place_prefix_field_name date_prefix_field_name
search =
let search =
match getd date_prefix_field_name with
| Some d1, Some d2 ->
search ^^^ " "
^<^ transl conf "between (date)"
^<^ DateDisplay.string_of_date conf d1
^^^ " " ^<^ transl conf "and" ^<^ " "
^<^ DateDisplay.string_of_date conf d2
| Some d1, _ ->
search ^^^ " " ^<^ transl conf "after (date)" ^<^ " "
^<^ DateDisplay.string_of_date conf d1
| _, Some d2 ->
search ^^^ " "
^<^ transl conf "before (date)"
^<^ " "
^<^ DateDisplay.string_of_date conf d2
| _ -> search
in
if test_string place_prefix_field_name then
search ^^^ " " ^<^ transl conf "in (place)" ^<^ " "
^<^ (escape_html (gets place_prefix_field_name) :> Adef.safe_string)
else search
in
(* Returns the event request. (e.g.: born in...) *)
let get_event_field_request place_prefix_field_name date_prefix_field_name
event_name search search_type =
(* Separator character depends on search type operator, a comma for AND search, a slash for OR search. *)
let sep : Adef.safe_string =
if (search : Adef.safe_string :> string) <> "" then
if search_type <> "OR" then Adef.safe ", " else Adef.safe " / "
else Adef.safe ""
in
let search =
if test_string place_prefix_field_name || test_date date_prefix_field_name
then search ^^^ sep ^>^ transl_nth conf event_name sex
else search
in
(* The place and date have to be shown after each event only for the AND request. *)
if search_type <> "OR" then
get_place_date_request place_prefix_field_name date_prefix_field_name
search
else search
in
let sosa_field search =
if gets "sosa_filter" <> "" then
match Util.find_sosa_ref conf base with
| Some p ->
let s =
Adef.safe
@@ Printf.sprintf
(ftransl conf "direct ancestor of %s")
(Util.gen_person_text conf base p : Adef.safe_string :> string)
in
if (search : Adef.safe_string :> string) = "" then s
else if (s :> string) = "" then search
else search ^^^ ", " ^<^ s
| None -> search
else search
in
(* Search type can be AND or OR. *)
let search_type = gets "search_type" in
let bapt_date_field_name =
get_event_field_name gets "date" "bapt" search_type
in
let birth_date_field_name =
get_event_field_name gets "date" "birth" search_type
in
let death_date_field_name =
get_event_field_name gets "date" "death" search_type
in
let burial_date_field_name =
get_event_field_name gets "date" "burial" search_type
in
let marriage_date_field_name =
get_event_field_name gets "date" "marriage" search_type
in
let bapt_place_field_name =
get_event_field_name gets "place" "bapt" search_type
in
let birth_place_field_name =
get_event_field_name gets "place" "birth" search_type
in
let death_place_field_name =
get_event_field_name gets "place" "death" search_type
in
let burial_place_field_name =
get_event_field_name gets "place" "burial" search_type
in
let marriage_place_field_name =
get_event_field_name gets "place" "marriage" search_type
in
let search = Adef.safe "" in
let search = string_field "first_name" search in
let search = string_field "surname" search in
let search = sosa_field search in
let event_search = Adef.safe "" in
let event_search =
get_event_field_request birth_place_field_name birth_date_field_name "born"
event_search search_type
in
let event_search =
get_event_field_request bapt_place_field_name bapt_date_field_name
"baptized" event_search search_type
in
let event_search =
get_event_field_request marriage_place_field_name marriage_date_field_name
"married" event_search search_type
in
let event_search =
get_event_field_request death_place_field_name death_date_field_name "died"
event_search search_type
in
let event_search =
get_event_field_request burial_place_field_name burial_date_field_name
"buried" event_search search_type
in
let search =
if (search :> string) = "" then event_search
else if (event_search :> string) = "" then search
else search ^^^ ", " ^<^ event_search
in
(* Adding the place and date at the end for the OR request. *)
let search =
if
search_type = "OR"
&& (gets "place" != ""
|| gets "date2_yyyy" != ""
|| gets "date1_yyyy" != "")
then get_place_date_request "place" "date" search
else search
in
let search =
if not (test_string marriage_place_field_name || test_date "marriage") then
let sep = if (search :> string) <> "" then ", " else "" in
if gets "married" = "Y" then
search ^>^ sep ^ transl conf "having a family"
else if gets "married" = "N" then
search ^>^ sep ^ transl conf "having no family"
else search
else search
in
let sep = Adef.safe (if (search :> string) <> "" then "," else "") in
string_field "occu" (search ^^^ sep)

9
lib/advSearchOk.mli Normal file
View File

@@ -0,0 +1,9 @@
val advanced_search :
Config.config -> Gwdb.base -> int -> Gwdb.person list * int
(** [advanced_search conf base max_answers] extracts advaced request fields from environement [conf.env] and
returns at most [max_answers] persons from the [base] that match conditions described by those fields. Seond result
represents real number of matches (if less then [max_answers]). *)
val searching_fields : Config.config -> Gwdb.base -> Adef.safe_string
(** Returns a description string for the current advanced search results in the correct language.
e.g. "Search all Pierre, born in Paris, died in Paris" *)

46
lib/advSearchOkDisplay.ml Normal file
View File

@@ -0,0 +1,46 @@
(* Copyright (c) 1998-2007 INRIA *)
open Config
open Util
let print_result conf base max_answers (list, len) =
let list =
if len > max_answers then Util.reduce_list max_answers list else list
in
if len = 0 then (
Output.print_sstring conf (Utf8.capitalize_fst (transl conf "no match"));
Output.print_sstring conf " ")
else
let () = SosaCache.build_sosa_ht conf base in
Output.print_sstring conf "<ul>\n";
List.iter
(fun p ->
Output.print_sstring conf "<li>";
SosaCache.print_sosa conf base p true;
Output.print_sstring conf " ";
Output.print_string conf (referenced_person_text conf base p);
Output.print_string conf (DateDisplay.short_dates_text conf base p);
Output.print_sstring conf "<em>";
specify_homonymous conf base p false;
Output.print_sstring conf "</em>")
list;
if len > max_answers then Output.print_sstring conf "<li>...</li>";
Output.print_sstring conf "</ul>"
let print conf base =
let title _ =
transl_nth conf "advanced request" 0
|> Utf8.capitalize_fst |> Output.print_sstring conf
in
let max_answers =
match p_getint conf.env "max" with Some n -> n | None -> 100
in
Hutil.header conf title;
Output.print_sstring conf "<p>";
Output.print_sstring conf (Utf8.capitalize_fst (transl conf "searching all"));
Output.print_sstring conf " ";
Output.print_string conf (AdvSearchOk.searching_fields conf base);
Output.print_sstring conf ".</p>";
let list = AdvSearchOk.advanced_search conf base max_answers in
print_result conf base max_answers list;
Hutil.trailer conf

2
lib/advSearchOkDisplay.mli Normal file
View File

@@ -0,0 +1,2 @@
val print : Config.config -> Gwdb.base -> unit
(** Displays the results of an advanced search *)

153
lib/alln.ml Normal file
View File

@@ -0,0 +1,153 @@
(* Copyright (c) 1998-2007 INRIA *)
open Config
open Gwdb
open Util
let default_max_cnt = 2000
(* selection *)
type t = Result of (string * string * int) list | Specify of string list
let first_letters base is_surnames =
let iii =
if is_surnames then persons_of_surname base else persons_of_first_name base
in
try
let rec loop istr list =
let s = Translate.eval (Mutil.nominative (sou base istr)) in
let k = Util.name_key base s in
let c = Utf8.sub k 0 1 in
let list =
match list with
| hd :: _ -> if hd = c then list else c :: list
| [] -> [ c ]
in
match spi_next iii istr with
| istr -> loop istr list
| exception Not_found -> list
in
loop (spi_first iii "") []
with Not_found -> []
let select_names conf base is_surnames ini limit =
let inilen = Utf8.length ini + 1 in
let cut k = Utf8.sub k 0 (min (Utf8.length k) inilen) in
let iii =
if is_surnames then persons_of_surname base else persons_of_first_name base
in
let list, len =
let start_k = Mutil.tr '_' ' ' ini in
try
let istr = spi_first iii start_k in
let rec loop istr len list =
let s = Translate.eval (Mutil.nominative (sou base istr)) in
let k = Util.name_key base s in
if Mutil.start_with_wildcard ini 0 k then
let list, len =
if s <> "?" then
let ips = spi_find iii istr in
let cnt =
(* Optimization:
* In the case of [Specify _]:
* [cnt] is not used except for zero equality test
* so we can use List.exists in order to avoid useless operations *)
match list with
| Specify _ ->
if ips = [] then 0
else if conf.use_restrict then
if
List.exists
(fun i -> not @@ is_restricted conf base i)
ips
then 1
else 0
else if conf.hide_names then
if
List.exists
(fun i -> Util.authorized_age conf base (poi base i))
ips
then 1
else 0
else 1
| Result _ ->
if conf.use_restrict then
List.fold_left
(fun acc i ->
if is_restricted conf base i then acc else acc + 1)
0 ips
else if conf.hide_names then
List.fold_left
(fun acc i ->
if Util.authorized_age conf base (poi base i) then
acc + 1
else acc)
0 ips
else List.length ips
in
if cnt = 0 then (list, len)
else
match list with
| Result ((k1, s1, cnt1) :: tl) when k = k1 ->
(Result ((k1, s1, cnt1 + cnt) :: tl), len)
| Result acc ->
if len >= limit then
let k = cut k in
match
List.sort_uniq
(fun a b -> compare b a)
(List.map (fun (k, _, _) -> cut k) acc)
with
| hd :: _ as acc when hd = k -> (Specify acc, len + 1)
| acc -> (Specify (k :: acc), len + 1)
else (Result ((k, s, cnt) :: acc), len + 1)
| Specify (k1 :: tl) ->
let k = cut k in
((if k = k1 then list else Specify (k :: k1 :: tl)), len + 1)
| Specify [] -> (Specify [ cut k ], 1)
else (list, len)
in
match spi_next iii istr with
| istr -> loop istr len list
| exception Not_found -> (list, len)
else (list, len)
in
loop istr 0 (Result [])
with Not_found -> (Result [], 0)
in
let list, len =
match list with
| Specify _ -> (list, len)
| Result acc -> (
match p_getint conf.env "atleast" with
| None -> (list, len)
| Some min ->
let acc, len =
List.fold_left
(fun (list, len) (k, s, cnt) ->
if cnt >= min then ((k, s, cnt) :: list, len)
else (list, len - 1))
([], len) acc
in
(Result acc, len))
in
(list, len)
let ini len k =
let ini_k = if Utf8.length k <= len then k else Utf8.sub k 0 len in
Mutil.unsafe_tr ' ' '_' ini_k
let groupby_ini len list =
list
|> Mutil.groupby
~key:(fun (k, _, _) -> ini len k)
~value:(fun (_, s, c) -> (s, c))
|> List.sort (fun (a, _) (b, _) -> Gutil.alphabetic_order a b)
let groupby_count = function
| Specify _ -> assert false
| Result list ->
list
|> Mutil.groupby ~key:(fun (_, _, c) -> c) ~value:(fun (_, s, _) -> s)
|> List.sort (fun (a, _) (b, _) -> compare b a)

38
lib/alln.mli Normal file
View File

@@ -0,0 +1,38 @@
val default_max_cnt : int
(** Default number of names that could be printed simultaneously on the page *)
(** Type that represents result of name selection *)
type t =
| Result of (string * string * int) list
(** Exhaustive result with the list of names
(key and printable name) with number of
persons that have giving name*)
| Specify of string list
(** Not exhaustive result that specifies all existing names
prefixes (their length depends on initial searched prefix) *)
val first_letters : Gwdb.base -> bool -> string list
(** Returns list of all first name's first letter present in the base (UTF8 encoded).
Used for fast access for base's names *)
val select_names :
Config.config -> Gwdb.base -> bool -> string -> int -> t * int
(** [select_names conf base is_surnames ini limit]
Select up to [limit] first names/surnames starting with [ini].
If more values are available, return [Specify] with different
possible prefixes with the length at most equal to the length of [ini]+1
(for empty [ini] specifies all first letters of existing names).
Otherwise, return the list of values [Result] with all first names
and number of persons that have giving name. *)
val ini : int -> string -> string
(** Returns prefix of length [len] of UTF8 encoded name *)
val groupby_ini :
int -> (string * 'a * 'b) list -> (string * ('a * 'b) list) list
(** [groupby_ini len results] returns alphabeticaly ordered list of grouped by name prefix (with length [len])
results. *)
val groupby_count : t -> (int * string list) list
(** Returns ordered (from bigest to smallest) list of grouped by name frequency (number of persons
having the name) results. Shouldn't be used when results are represented with [Specify]. *)

322
lib/allnDisplay.ml Normal file
View File

@@ -0,0 +1,322 @@
open Def
open Config
open Gwdb
open Util
let default_max_cnt = Alln.default_max_cnt
(* tools *)
let particle_at_the_end base is_surnames s =
if is_surnames then surname_without_particle base s ^ surname_particle base s
else s
let compare_particle_at_the_end base is_surnames a b =
Gutil.alphabetic_order
(particle_at_the_end base is_surnames a)
(particle_at_the_end base is_surnames b)
(* print *)
let print_title conf base is_surnames ini len =
if len >= 2 then
if is_surnames then
Printf.sprintf (fcapitale (ftransl conf "the %d surnames")) len
|> Output.print_sstring conf
else
Printf.sprintf (fcapitale (ftransl conf "the %d first names")) len
|> Output.print_sstring conf
else if is_surnames then
transl_nth conf "surname/surnames" 0
|> Utf8.capitalize_fst |> Output.print_sstring conf
else
transl_nth conf "first name/first names" 0
|> Utf8.capitalize_fst |> Output.print_sstring conf;
if ini <> "" then (
Output.print_sstring conf " ";
Output.print_sstring conf (transl conf "starting with");
Output.print_sstring conf " ";
Output.print_string conf (Util.escape_html ini))
else (
Output.print_sstring conf " (";
Output.print_sstring conf (string_of_int @@ Gwdb.nb_of_real_persons base);
Output.print_sstring conf " ";
Output.print_sstring conf
(Util.translate_eval ("@(c)" ^ transl_nth conf "person/persons" 1));
Output.print_sstring conf ")")
let tr c1 s2 s =
let rec loop i len =
if i = String.length s then Buff.get len
else if String.unsafe_get s i = c1 then loop (i + 1) (Buff.mstore len s2)
else loop (i + 1) (Buff.store len (String.unsafe_get s i))
in
loop 0 0
let print_alphabetic_big conf base is_surnames ini list len too_big =
let title _ = print_title conf base is_surnames ini len in
let mode = if is_surnames then Adef.encoded "N" else Adef.encoded "P" in
Hutil.header conf title;
Output.print_sstring conf {|<p class="search_name">|};
List.iter
(fun ini_k ->
if ini_k = ini then (
Output.print_sstring conf {|<a href="|};
Output.print_string conf (commd conf);
Output.print_sstring conf "m=";
Output.print_string conf mode;
Output.print_sstring conf "&tri=A&v=";
Output.print_string conf (Mutil.encode ini_k);
Output.print_sstring conf {|">|})
else (
Output.print_sstring conf {|<a href="|};
Output.print_string conf (commd conf);
Output.print_sstring conf "m=";
Output.print_string conf mode;
Output.print_sstring conf "&tri=A&k=";
Output.print_string conf (Mutil.encode ini_k);
Output.print_sstring conf {|">|});
Output.print_string conf (tr '_' "&nbsp;" ini_k |> Util.escape_html);
Output.print_sstring conf "</a>\n")
list;
if not too_big then (
Output.print_sstring conf "</p><p>";
transl conf "the whole list"
|> Utf8.capitalize_fst |> Output.print_sstring conf;
Output.print_sstring conf (transl conf ":");
Output.print_sstring conf "</p><ul><li>";
Output.print_sstring conf {|<a href="|};
Output.print_string conf (commd conf);
Output.print_sstring conf "m=";
Output.print_string conf mode;
Output.print_sstring conf "&tri=A&o=A&k=";
Output.print_string conf (Mutil.encode ini);
Output.print_sstring conf {|">|};
Output.print_sstring conf (transl conf "long display");
Output.print_sstring conf "</a></li><li>";
Output.print_sstring conf {|<a href="|};
Output.print_string conf (commd conf);
Output.print_sstring conf "m=";
Output.print_string conf mode;
Output.print_sstring conf "&tri=S&o=A&k=";
Output.print_string conf (Mutil.encode ini);
Output.print_sstring conf {|">|};
Output.print_sstring conf (transl conf "short display");
Output.print_sstring conf "</a></li><li>";
Output.print_sstring conf {|<a href="|};
Output.print_string conf (commd conf);
Output.print_sstring conf "m=";
Output.print_string conf mode;
Output.print_sstring conf "&tri=S&o=A&cgl=on&k=";
Output.print_string conf (Mutil.encode ini);
Output.print_sstring conf {|">|};
Output.print_sstring conf (transl conf "short display");
Output.print_sstring conf " + ";
Output.print_sstring conf (transl conf "cancel GeneWeb links");
Output.print_sstring conf "</a></li></ul>");
Hutil.trailer conf
let print_alphabetic_all conf base is_surnames ini list len =
let title _ = print_title conf base is_surnames ini len in
let mode = Adef.encoded (if is_surnames then "N" else "P") in
Hutil.header conf title;
Output.print_sstring conf {|<p class="search_name">|};
List.iter
(fun (ini_k, _) ->
Output.print_sstring conf "<a href=\"#a";
Output.print_string conf (Mutil.encode ini_k);
Output.print_sstring conf "\">";
Output.print_string conf (Mutil.tr '_' ' ' ini_k |> Adef.safe);
Output.print_sstring conf "</a>\n")
list;
Output.print_sstring conf "</p><ul>";
List.iter
(fun (ini_k, l) ->
Output.print_sstring conf "<li><a id=\"a";
Output.print_string conf (Mutil.encode ini_k);
Output.print_sstring conf "\">";
Output.print_string conf (Mutil.tr '_' ' ' ini_k |> Adef.safe);
Output.print_sstring conf "</a><ul>";
List.iter
(fun (s, cnt) ->
Output.print_sstring conf "<li>";
let href = "m=" ^<^ mode ^^^ "&v=" ^<^ Mutil.encode s ^>^ "&t=A" in
wprint_geneweb_link conf
(href :> Adef.escaped_string)
(particle_at_the_end base is_surnames s |> Util.escape_html
:> Adef.safe_string);
Output.print_sstring conf " (";
Output.print_sstring conf (string_of_int cnt);
Output.print_sstring conf ")</li>")
(List.sort
(fun (a, _) (b, _) ->
compare_particle_at_the_end base is_surnames a b)
l);
Output.print_sstring conf "</ul></li>")
list;
Output.print_sstring conf "</ul>";
Hutil.trailer conf
let print_alphabetic_small conf base is_surnames ini list len =
let title _ = print_title conf base is_surnames ini len in
let mode = Adef.encoded (if is_surnames then "N" else "P") in
Hutil.header conf title;
if list <> [] then (
Output.print_sstring conf "<ul>";
List.iter
(fun (_, s, cnt) ->
Output.print_sstring conf "<li>";
Output.print_sstring conf "<a href=\"";
Output.print_string conf (commd conf);
Output.print_sstring conf "m=";
Output.print_string conf mode;
Output.print_sstring conf "&v=";
Output.print_string conf (Mutil.encode s);
Output.print_sstring conf "&t=A\">";
Output.print_string conf
(particle_at_the_end base is_surnames s |> Util.escape_html);
Output.print_sstring conf "</a> (";
Output.print_sstring conf (string_of_int cnt);
Output.print_sstring conf ")</li>")
(List.sort
(fun (_, a, _) (_, b, _) ->
compare_particle_at_the_end base is_surnames a b)
list);
Output.print_sstring conf "</ul>");
Hutil.trailer conf
let print_frequency_any conf base is_surnames list len =
let title _ = print_title conf base is_surnames "" len in
let mode = Adef.encoded (if is_surnames then "N" else "P") in
let n = ref 0 in
Hutil.header conf title;
Output.print_sstring conf "<ul>";
List.iter
(fun (cnt, l) ->
if !n <= default_max_cnt then (
Output.print_sstring conf "<li>";
Output.print_sstring conf (string_of_int cnt);
Output.print_sstring conf "<ul>";
List.iter
(fun s ->
Output.print_sstring conf "<li><a href=\"";
Output.print_string conf (commd conf);
Output.print_sstring conf "m=";
Output.print_string conf mode;
Output.print_sstring conf "&v=";
Output.print_string conf (Mutil.encode (Name.lower s));
Output.print_sstring conf "\">";
Output.print_string conf
(particle_at_the_end base is_surnames s |> Util.escape_html);
Output.print_sstring conf "</a></li>";
incr n)
l;
Output.print_sstring conf "</ul>";
Output.print_sstring conf "</li>"))
list;
Output.print_sstring conf "</ul>";
Hutil.trailer conf
let print_frequency conf base is_surnames =
let () = load_strings_array base in
let list, len = Alln.select_names conf base is_surnames "" max_int in
let list = Alln.groupby_count list in
print_frequency_any conf base is_surnames list len
let print_alphabetic conf base is_surnames =
let ini = match p_getenv conf.env "k" with Some k -> k | _ -> "" in
if List.assoc_opt "fast_alphabetic" conf.base_env = Some "yes" && ini = ""
then (
load_strings_array base;
let list = Alln.first_letters base is_surnames in
let list = List.sort Gutil.alphabetic_order list in
print_alphabetic_big conf base is_surnames ini list 1 true)
else
let all =
match p_getenv conf.env "o" with Some "A" -> true | _ -> false
in
if String.length ini < 2 then load_strings_array base;
let list, len =
Alln.select_names conf base is_surnames ini (if all then max_int else 50)
in
match list with
| Alln.Specify keys ->
let keys = List.sort Gutil.alphabetic_order keys in
let too_big = (not all) && List.length keys > Alln.default_max_cnt in
print_alphabetic_big conf base is_surnames ini keys len too_big
| Alln.Result list ->
if len >= 50 || ini = "" then
let list = Alln.groupby_ini (Utf8.length ini + 1) list in
print_alphabetic_all conf base is_surnames ini list len
else print_alphabetic_small conf base is_surnames ini list len
(* short print *)
let print_alphabetic_short conf base is_surnames ini list len =
let title _ = print_title conf base is_surnames ini len in
let mode = Adef.encoded (if is_surnames then "N" else "P") in
let need_ref = len >= 250 in
Hutil.header conf title;
if need_ref then (
Output.print_sstring conf "<p>";
List.iter
(fun (ini_k, _) ->
Output.print_sstring conf "<a href=\"#a";
Output.print_string conf (Mutil.encode ini_k);
Output.print_sstring conf "\">";
Output.print_string conf (Mutil.tr '_' ' ' ini_k |> Util.escape_html);
Output.print_sstring conf "</a>\n")
list;
Output.print_sstring conf "</p>");
List.iter
(fun (ini_k, l) ->
Output.print_sstring conf "<p>";
Mutil.list_iter_first
(fun first (s, cnt) ->
let href =
" href=\"" ^<^ commd conf
^^^ ("m=" ^<^ mode ^^^ "&v=" ^<^ Mutil.encode s ^>^ "&t=A\""
:> Adef.escaped_string)
in
let name =
Adef.encoded
(if first && need_ref then " id=\"a" ^ ini_k ^ "\"" else "")
in
if not first then Output.print_sstring conf ",";
Output.print_sstring conf "\n<a";
Output.print_string conf href;
Output.print_string conf name;
Output.print_sstring conf ">";
Output.print_string conf
(particle_at_the_end base is_surnames s |> Util.escape_html);
Output.print_sstring conf "</a>";
Output.print_sstring conf "&nbsp;(";
Output.print_sstring conf (string_of_int cnt);
Output.print_sstring conf ")")
(List.sort (fun (a, _) (b, _) -> Gutil.alphabetic_order a b) l);
Output.print_sstring conf "</p>")
list;
Hutil.trailer conf
let print_short conf base is_surnames =
let ini = match p_getenv conf.env "k" with Some k -> k | _ -> "" in
let _ = if String.length ini < 2 then load_strings_array base in
match Alln.select_names conf base is_surnames ini max_int with
| Alln.Specify _, _ -> Hutil.incorrect_request conf
| Alln.Result list, len ->
let list = Alln.groupby_ini (Utf8.length ini + 1) list in
print_alphabetic_short conf base is_surnames ini list len
(* main *)
let print_surnames conf base =
match p_getenv conf.env "tri" with
| Some "F" -> print_frequency conf base true
| Some "S" -> print_short conf base true
| _ -> print_alphabetic conf base true
let print_first_names conf base =
match p_getenv conf.env "tri" with
| Some "F" -> print_frequency conf base false
| Some "S" -> print_short conf base false
| _ -> print_alphabetic conf base false

13
lib/allnDisplay.mli Normal file
View File

@@ -0,0 +1,13 @@
val print_surnames : Config.config -> Gwdb.base -> unit
(** Displays all persons surnames present in the base. Display could be different depending
on environement [conf.env]. These variables affect the display:
- tri : "F" to display surnames by frequency, "S" to display
surnames regrouped by first letter (depends on variable "k")
otherwsise display surnames just ordered alphabeticaly
- k : Defines common prefix for surnames (empty for all)
- o : "A" to print all surnames (if less then [Alln.default_max_cnt])
otherwise prints links to access different type of displaying *)
val print_first_names : Config.config -> Gwdb.base -> unit
(** Same as [print_surnames] but dealing with first names. *)

283
lib/ansel.ml Normal file
View File

@@ -0,0 +1,283 @@
(* $Id: ansel.ml,v 5.3 2007-01-19 01:53:16 ddr Exp $ *)
(* Copyright (c) 1998-2007 INRIA *)
let iso_8859_1_unknown = '\129'
let ansel_unknown = 129
let no_accent = function
| '\224' .. '\229' -> 'a'
| '\162' | '\231' -> 'c'
| '\232' .. '\235' -> 'e'
| '\236' .. '\239' -> 'i'
| '\241' -> 'n'
| '\242' .. '\246' -> 'o'
| '\249' .. '\252' -> 'u'
| '\253' | '\255' -> 'y'
| '\192' .. '\197' -> 'A'
| '\199' -> 'C'
| '\200' .. '\203' -> 'E'
| '\204' .. '\207' -> 'I'
| '\209' -> 'N'
| '\210' .. '\214' -> 'O'
| '\217' .. '\220' -> 'U'
| '\221' -> 'Y'
| '\168' | '\176' | '\180' | '\184' | '\186' -> ' '
| '\171' -> '<'
| '\187' -> '>'
| c -> c
let accent_code = (* and 1-to-1 conversions *)
function
| '\192' | '\200' | '\204' | '\210' | '\217' | '\224' | '\232' | '\236'
| '\242' | '\249' ->
225
| '\193' | '\201' | '\205' | '\211' | '\218' | '\221' | '\180' | '\225'
| '\233' | '\237' | '\243' | '\250' | '\253' ->
226
| '\194' | '\202' | '\206' | '\212' | '\219' | '\226' | '\234' | '\238'
| '\244' | '\251' ->
227
| '\195' | '\209' | '\213' | '\227' | '\241' | '\245' -> 228
| '\196' | '\203' | '\207' | '\214' | '\220' | '\168' | '\228' | '\235'
| '\239' | '\246' | '\252' | '\255' ->
232
| '\197' | '\229' | '\176' | '\186' -> 234
| '\199' | '\231' | '\184' -> 240
| '\161' -> 198
| '\162' -> 252
| '\163' -> 185
| '\164' -> 0x6f
| '\165' -> 0x59
| '\166' -> 0x7c
| '\169' -> 195
| '\170' -> 0x61
| '\171' -> 0x3c
| '\173' -> 0x2d
| '\174' -> 170
| '\177' -> 171
| '\178' -> 0x32
| '\179' -> 0x33
| '\183' -> 168
| '\185' -> 0x31
| '\187' -> 0x3e
| '\191' -> 197
| '\198' -> 165
| '\230' -> 181
| '\208' -> 163
| '\240' -> 179
| '\216' -> 162
| '\248' -> 178
| '\222' -> 164
| '\254' -> 180
| '\223' -> 207
| c when c >= '\161' -> ansel_unknown
| _ -> 0
let of_iso_8859_1 s =
let len, identical =
let rec loop i len identical =
if i = String.length s then (len, identical)
else
let a = accent_code s.[i] in
if a = 0 then loop (i + 1) (len + 1) identical
else
let n = no_accent s.[i] in
if n = s.[i] then loop (i + 1) (len + 1) false
else loop (i + 1) (len + 2) false
in
loop 0 0 true
in
if identical then s
else
let s' = Bytes.create len in
let rec loop i i' =
if i = String.length s then Bytes.unsafe_to_string s'
else
let i' =
let a = accent_code s.[i] in
if a > 0 then (
Bytes.set s' i' (Char.chr a);
let n = no_accent s.[i] in
if n = s.[i] then i'
else (
Bytes.set s' (i' + 1) n;
i' + 1))
else (
Bytes.set s' i' s.[i];
i')
in
loop (i + 1) (i' + 1)
in
loop 0 0
let grave = function
| 'a' -> '\224'
| 'e' -> '\232'
| 'i' -> '\236'
| 'o' -> '\242'
| 'u' -> '\249'
| 'A' -> '\192'
| 'E' -> '\200'
| 'I' -> '\204'
| 'O' -> '\210'
| 'U' -> '\217'
| ' ' -> '`'
| x -> x
let acute = function
| 'a' -> '\225'
| 'e' -> '\233'
| 'i' -> '\237'
| 'o' -> '\243'
| 'u' -> '\250'
| 'y' -> '\253'
| 'A' -> '\193'
| 'E' -> '\201'
| 'I' -> '\205'
| 'O' -> '\211'
| 'U' -> '\218'
| 'Y' -> '\221'
| ' ' -> '\180'
| x -> x
let circum = function
| 'a' -> '\226'
| 'e' -> '\234'
| 'i' -> '\238'
| 'o' -> '\244'
| 'u' -> '\251'
| 'A' -> '\194'
| 'E' -> '\202'
| 'I' -> '\206'
| 'O' -> '\212'
| 'U' -> '\219'
| ' ' -> '^'
| x -> x
let uml = function
| 'a' -> '\228'
| 'e' -> '\235'
| 'i' -> '\239'
| 'o' -> '\246'
| 'u' -> '\252'
| 'y' -> '\255'
| 'A' -> '\196'
| 'E' -> '\203'
| 'I' -> '\207'
| 'O' -> '\214'
| 'U' -> '\220'
| ' ' -> '\168'
| x -> x
let circle = function 'a' -> '\229' | 'A' -> '\197' | ' ' -> '\176' | x -> x
let tilde = function
| 'a' -> '\227'
| 'n' -> '\241'
| 'o' -> '\245'
| 'A' -> '\195'
| 'N' -> '\209'
| 'O' -> '\213'
| ' ' -> '~'
| x -> x
let cedil = function 'c' -> '\231' | 'C' -> '\199' | ' ' -> '\184' | x -> x
let slash = function
| 'C' | 'c' -> '\162'
| 'O' -> '\216'
| 'o' -> '\248'
| ' ' -> '/'
| x -> x
let to_iso_8859_1 s =
let len, identical =
let rec loop i len identical =
if i = String.length s then (len, identical)
else if i = String.length s - 1 then (len + 1, identical)
else
match Char.code s.[i] with
| 166 | 172 | 173 | 182 | 188 | 189 -> loop (i + 1) (len + 2) false
| c when c >= 224 -> loop (i + 2) (len + 1) false
| c when c >= 161 -> loop (i + 1) (len + 1) false
| _ -> loop (i + 1) (len + 1) identical
in
loop 0 0 true
in
if identical then s
else
let s' = Bytes.create len in
let rec loop i i' =
if i = String.length s then Bytes.unsafe_to_string s'
else if i = String.length s - 1 then (
Bytes.set s' i' s.[i];
Bytes.unsafe_to_string s')
else
match Char.code s.[i] with
| (166 | 172 | 173 | 182 | 188 | 189) as c ->
let c', c'' =
match c with
| 166 -> ('O', 'E')
| 172 -> ('O', '\180')
| 173 -> ('U', '\180')
| 182 -> ('o', 'e')
| 188 -> ('o', '\180')
| 189 -> ('u', '\180')
| _ -> (iso_8859_1_unknown, iso_8859_1_unknown)
in
Bytes.set s' i' c';
Bytes.set s' (i' + 1) c'';
loop (i + 1) (i' + 2)
| c when c >= 224 ->
let c' = s.[i + 1] in
let c' =
match c with
| 224 | 226 | 235 | 237 | 254 -> acute c'
| 225 | 236 -> grave c'
| 227 | 250 -> circum c'
| 228 | 230 | 233 -> tilde c'
| 232 | 238 -> uml c'
| 231 | 234 -> circle c'
| 240 | 241 | 242 | 243 | 244 | 247 | 248 | 249 -> cedil c'
| 252 -> slash c'
| _ -> c'
in
Bytes.set s' i' c';
loop (i + 2) (i' + 1)
| c ->
let c' =
match c with
| 161 -> 'L'
| 162 -> '\216'
| 163 -> '\208'
| 164 -> '\222'
| 165 -> '\198'
| 167 | 174 | 176 -> '\180'
| 168 -> '\183'
| 169 -> 'b'
| 170 -> '\174'
| 171 -> '\177'
| 177 | 193 -> 'l'
| 178 -> '\248'
| 179 | 186 -> '\240'
| 180 -> '\254'
| 181 -> '\230'
| 183 -> '"'
| 184 -> 'i'
| 185 -> '\163'
| 190 | 191 -> iso_8859_1_unknown
| 192 -> '\176'
| 194 -> 'P'
| 195 -> '\169'
| 196 -> '#'
| 197 -> '\191'
| 198 -> '\161'
| 205 -> '\101'
| 206 -> '\111'
| 207 -> '\223'
| _ -> Char.chr c
in
Bytes.set s' i' c';
loop (i + 1) (i' + 1)
in
loop 0 0

5
lib/ansel.mli Normal file
View File

@@ -0,0 +1,5 @@
val of_iso_8859_1 : string -> string
(** Convert ISO-8859-1 encoded string to ANSEL encoding used inside gedcom files *)
val to_iso_8859_1 : string -> string
(** Convert ANSEL used inside gedcom files to ISO-8859-1 encoding *)

68
lib/ascendDisplay.ml Normal file
View File

@@ -0,0 +1,68 @@
(* Copyright (c) 1998-2007 INRIA *)
open Config
open Gwdb
open Util
let limit_by_tree conf =
match List.assoc_opt "max_anc_tree" conf.base_env with
| Some x -> max 1 (int_of_string x)
| None -> 7
let print_ancestors_dag conf base v p =
let v = min (limit_by_tree conf) v in
let set =
(* TODO this should be a get_ancestors_set lvl ip *)
let rec loop set lev ip =
let set = Dag.Pset.add ip set in
if lev <= 0 then set
else
match get_parents (pget conf base ip) with
| Some ifam ->
let cpl = foi base ifam in
let get_left, get_right =
match p_getenv conf.env "mf" with
| Some "1" -> (get_father, get_mother)
| _ -> (get_mother, get_father)
in
let set = loop set (lev - 1) (get_left cpl) in
loop set (lev - 1) (get_right cpl)
| None -> set
in
loop Dag.Pset.empty v (get_iper p)
in
let elem_txt p = DagDisplay.Item (p, Adef.safe "") in
(* Récupère les options d'affichage. *)
let options = Util.display_options conf in
let vbar_txt ip =
let p = pget conf base ip in
Printf.sprintf {|%s%s&m=A&t=T&dag=on&v=%d%s |}
(commd conf :> string)
(acces conf base p :> string)
v
(options :> string)
|> Adef.escaped
in
let page_title =
Util.transl conf "tree" |> Utf8.capitalize_fst |> Adef.safe
in
DagDisplay.make_and_print_dag conf base elem_txt vbar_txt true set []
page_title (Adef.escaped "")
let print conf base p =
match
( Util.p_getenv conf.env "t",
Util.p_getenv conf.env "dag",
p_getint conf.env "v" )
with
| Some "T", Some "on", Some v -> print_ancestors_dag conf base v p
| _ ->
let templ =
match Util.p_getenv conf.env "t" with
| Some ("E" | "F" | "H" | "L") -> "anclist"
| Some ("D" | "G" | "M" | "N" | "P" | "X" | "Y" | "Z") -> "ancsosa"
| Some ("A" | "C" | "T") -> "anctree"
| Some "FC" -> "fanchart"
| _ -> "ancmenu"
in
Perso.interp_templ templ conf base p

115
lib/birthDeath.ml Normal file
View File

@@ -0,0 +1,115 @@
(* Copyright (c) 1998-2007 INRIA *)
open Config
open Def
open Gwdb
open Util
let get_k conf =
match p_getint conf.env "k" with
| Some x -> x
| _ -> (
try int_of_string (List.assoc "latest_event" conf.base_env)
with Not_found | Failure _ -> 20)
let select (type a) (module Q : Pqueue.S with type elt = a * dmy * calendar)
nb_of iterator get get_date conf base =
let n = min (max 0 (get_k conf)) (nb_of base) in
let ref_date =
match p_getint conf.env "by" with
| Some by ->
let bm = Option.value ~default:(-1) (p_getint conf.env "bm") in
let bd = Option.value ~default:(-1) (p_getint conf.env "bd") in
Some { day = bd; month = bm; year = by; prec = Sure; delta = 0 }
| None -> None
in
let q, len =
Gwdb.Collection.fold
(fun (q, len) i ->
let x = get base i in
match get_date x with
| Some (Dgreg (d, cal)) ->
let aft =
match ref_date with
| Some ref_date -> Date.compare_dmy ref_date d <= 0
| None -> false
in
if aft then (q, len)
else
let e = (x, d, cal) in
if len < n then (Q.add e q, len + 1)
else (snd (Q.take (Q.add e q)), len)
| _ -> (q, len))
(Q.empty, 0) (iterator base)
in
let rec loop list q =
if Q.is_empty q then (list, len)
else
let e, q = Q.take q in
loop (e :: list) q
in
loop [] q
module PQ = Pqueue.Make (struct
type t = Gwdb.person * Def.dmy * Def.calendar
let leq (_, x, _) (_, y, _) = Date.compare_dmy x y <= 0
end)
module PQ_oldest = Pqueue.Make (struct
type t = Gwdb.person * Def.dmy * Def.calendar
let leq (_, x, _) (_, y, _) = Date.compare_dmy y x <= 0
end)
let select_person conf base get_date find_oldest =
select
(if find_oldest then (module PQ_oldest) else (module PQ))
nb_of_persons Gwdb.ipers (pget conf) get_date conf base
module FQ = Pqueue.Make (struct
type t = Gwdb.family * Def.dmy * Def.calendar
let leq (_, x, _) (_, y, _) = Date.compare_dmy x y <= 0
end)
module FQ_oldest = Pqueue.Make (struct
type t = Gwdb.family * Def.dmy * Def.calendar
let leq (_, x, _) (_, y, _) = Date.compare_dmy y x <= 0
end)
let select_family conf base get_date find_oldest =
select
(if find_oldest then (module FQ_oldest) else (module FQ))
nb_of_families Gwdb.ifams Gwdb.foi get_date conf base
let death_date p = Date.date_of_death (get_death p)
let make_population_pyramid ~nb_intervals ~interval ~limit ~at_date conf base =
let men = Array.make (nb_intervals + 1) 0 in
let wom = Array.make (nb_intervals + 1) 0 in
(* TODO? Load person array *)
Gwdb.Collection.iter
(fun i ->
let p = pget conf base i in
let sex = get_sex p in
let dea = get_death p in
if sex <> Neuter then
match Date.cdate_to_dmy_opt (get_birth p) with
| None -> ()
| Some dmy ->
if Date.compare_dmy dmy at_date <= 0 then
let a = Date.time_elapsed dmy at_date in
let j = min nb_intervals (a.year / interval) in
if
(dea = NotDead || (dea = DontKnowIfDead && a.year < limit))
||
match Date.dmy_of_death dea with
| None -> false
| Some d -> Date.compare_dmy d at_date > 0
then
if sex = Male then men.(j) <- men.(j) + 1
else wom.(j) <- wom.(j) + 1)
(Gwdb.ipers base);
(men, wom)

44
lib/birthDeath.mli Normal file
View File

@@ -0,0 +1,44 @@
val select_person :
Config.config ->
Gwdb.base ->
(Gwdb.person -> Def.date option) ->
bool ->
(Gwdb.person * Def.dmy * Def.calendar) list * int
(** [select_person conf base get_date find_oldest] select 20 persons
from the base according to the one of their date (birth, death,
marriage, specific event, etc.) that could be get with [get_date].
Returns sorted by date persons that have the latest (if [find_oldest]
is false) or oldest (otherwise) date. Selection could be different depending
on environement [conf.env]. These variables affect the selection:
k - allows to modify default value (20) of selected persons
by,bm,bd - allows to set reference date (all dates after the reference
one aren't selected)
Returns also the number of selected persons *)
val select_family :
Config.config ->
Gwdb.base ->
(Gwdb.family -> Def.date option) ->
bool ->
(Gwdb.family * Def.dmy * Def.calendar) list * int
(** Same as [select_person] but dealing with families *)
val death_date : Gwdb.person -> Adef.date option
(** Returns person's death date (if exists) *)
val make_population_pyramid :
nb_intervals:int ->
interval:int ->
limit:int ->
at_date:Def.dmy ->
Config.config ->
Gwdb.base ->
int array * int array
(** [make_population_pyramid nb_intervals interval interval at_date conf base]
Calculates population pyramid of all perons in the base. Population pyramid
consists of two separated arrays that regroups number of men's and women's born
in each time interval. One array has a size [nb_intervals + 1] and every element
is a number of persons born in the giving time interval that represents [interval] years.
Calculation starts at the date [at_date] and persons that are considered
in pyramid should be alive at this date. [limit] allows to limit persons
by age (those that has age greater then limit aren't taken into the account) *)

553
lib/birthDeathDisplay.ml Normal file
View File

@@ -0,0 +1,553 @@
(* Copyright (c) 1998-2007 INRIA *)
open Config
open Def
open Gwdb
open Util
open BirthDeath
let month_txt conf d cal =
let d = DateDisplay.string_of_date conf (Dgreg ({ d with day = 0 }, cal)) in
(d : Adef.safe_string :> string) |> Utf8.capitalize_fst |> Adef.safe
let list_aux_1 conf d cal last_month_txt was_future =
let month_txt = month_txt conf d cal in
let future = Date.compare_dmy d conf.today = 1 in
if (not future) && was_future then (
Output.print_sstring conf "</li></ul></li></ul><p><ul><li>";
Output.print_string conf month_txt;
Output.print_sstring conf "<ul>")
else if month_txt <> last_month_txt then (
if (last_month_txt :> string) <> "" then
Output.print_sstring conf "</ul></li>";
Output.print_sstring conf "<li>";
Output.print_string conf month_txt;
Output.print_sstring conf "<ul>");
(month_txt, future)
let print_birth conf base =
let list, len =
select_person conf base (fun p -> Date.od_of_cdate (get_birth p)) false
in
let title _ =
Output.printf conf (fcapitale (ftransl conf "the latest %d births")) len
in
Hutil.header conf title;
Hutil.print_link_to_welcome conf true;
Output.print_sstring conf "<ul>\n";
ignore
@@ List.fold_left
(fun (last_month_txt, was_future) (p, d, cal) ->
let month_txt, future =
list_aux_1 conf d cal last_month_txt was_future
in
Output.print_sstring conf "<li><b>";
Output.print_string conf (referenced_person_text conf base p);
Output.print_sstring conf "</b>, ";
if future then (
Output.print_sstring conf "<em>";
Output.print_string conf
(DateDisplay.string_of_date conf (Dgreg (d, cal)));
Output.print_sstring conf "</em>.")
else (
Output.print_sstring conf
(transl_nth conf "born" (index_of_sex (get_sex p)));
Output.print_sstring conf " <em>";
Output.print_string conf
(DateDisplay.string_of_ondate conf (Dgreg (d, cal)));
Output.print_sstring conf "</em>.");
Output.print_sstring conf "</li>";
(month_txt, future))
(Adef.safe "", false)
list;
Output.print_sstring conf "</ul></li>";
Hutil.trailer conf
let print_death conf base =
let list, len = select_person conf base death_date false in
let title _ =
Printf.sprintf
(fcapitale (ftransl conf "the latest %t deaths"))
(fun _ -> string_of_int len)
|> Output.print_sstring conf
in
Hutil.header conf title;
Hutil.print_link_to_welcome conf true;
if list <> [] then (
Output.print_sstring conf "<ul>";
let _, ages_sum, ages_nb =
List.fold_left
(fun (last_month_txt, ages_sum, ages_nb) (p, d, cal) ->
let month_txt = month_txt conf d cal in
if month_txt <> last_month_txt then (
if (last_month_txt :> string) <> "" then
Output.print_sstring conf "</ul>\n</li>\n";
Output.print_sstring conf "<li>";
Output.print_string conf month_txt;
Output.print_sstring conf "<ul>");
let age, ages_sum, ages_nb =
let sure d = d.prec = Sure in
match Date.cdate_to_dmy_opt (get_birth p) with
| None -> (None, ages_sum, ages_nb)
| Some d1 ->
if sure d1 && sure d && d1 <> d then
let a = Date.time_elapsed d1 d in
let ages_sum =
match get_sex p with
| Male -> (fst ages_sum + a.year, snd ages_sum)
| Female -> (fst ages_sum, snd ages_sum + a.year)
| Neuter -> ages_sum
in
let ages_nb =
match get_sex p with
| Male -> (fst ages_nb + 1, snd ages_nb)
| Female -> (fst ages_nb, snd ages_nb + 1)
| Neuter -> ages_nb
in
(Some a, ages_sum, ages_nb)
else (None, ages_sum, ages_nb)
in
Output.print_sstring conf "<li><b>";
Output.print_string conf (referenced_person_text conf base p);
Output.print_sstring conf "</b>, ";
Output.print_sstring conf
(transl_nth conf "died" (index_of_sex (get_sex p)));
Output.print_sstring conf " <em>";
Output.print_string conf
(DateDisplay.string_of_ondate conf (Dgreg (d, cal)));
Output.print_sstring conf "</em>";
Option.iter
(fun a ->
Output.print_sstring conf " <em>(";
Output.print_string conf (DateDisplay.string_of_age conf a);
Output.print_sstring conf ")</em>")
age;
Output.print_sstring conf "</li>";
(month_txt, ages_sum, ages_nb))
(Adef.safe "", (0, 0), (0, 0))
list
in
Output.print_sstring conf "</ul></li></ul>";
let aux sex nb sum =
if nb >= 3 then (
transl conf "average age at death"
|> Utf8.capitalize_fst |> Output.print_sstring conf;
Output.print_sstring conf " (";
Output.print_sstring conf (transl_nth conf "M/F" sex);
Output.print_sstring conf ") : ";
Output.print_string conf
(DateDisplay.string_of_age conf
{ day = 0; month = 0; year = sum / nb; delta = 0; prec = Sure });
Output.print_sstring conf "<br>")
in
aux 0 (fst ages_nb) (fst ages_sum);
aux 1 (snd ages_nb) (snd ages_sum);
Output.print_sstring conf
{|<br><div align="center"><hr width="50%"></div><br>|};
let aux name def =
string_of_int
@@
match p_getenv conf.env name with
| Some s -> int_of_string s
| None -> def
in
let by = aux "by" conf.today.year in
let bm = aux "bm" conf.today.month in
let bd = aux "bd" conf.today.day in
Output.print_sstring conf {|<form method="get" action="|};
Output.print_sstring conf conf.command;
Output.print_sstring conf {|"><p>|};
Util.hidden_env conf;
Util.hidden_input conf "m" (Adef.encoded "LD");
Output.print_sstring conf
@@ Printf.sprintf
(fcapitale (ftransl conf "the latest %t deaths"))
(fun _ ->
{|<input name="k" value="|} ^ string_of_int len
^ {|" size="4" maxlength="4">|});
Output.print_sstring conf "\n... (";
Output.print_sstring conf (transl conf "before");
Output.print_sstring conf "...\n";
let aux name value size =
Output.print_sstring conf {|<input name="|};
Output.print_sstring conf name;
Output.print_sstring conf {|" value="|};
Output.print_sstring conf value;
Output.print_sstring conf {|" size="|};
Output.print_sstring conf size;
Output.print_sstring conf {|" maxlength="|};
Output.print_sstring conf size;
Output.print_sstring conf {|">|}
in
aux "by" by "4";
aux "bm" bm "2";
aux "bd" bd "2";
Output.print_sstring conf ")";
Output.print_sstring conf
{|<button type="submit" class="btn btn-primary btn-lg">|};
transl_nth conf "validate/delete" 0
|> Utf8.capitalize_fst |> Output.print_sstring conf;
Output.print_sstring conf "</button></p></form>");
Hutil.trailer conf
let print_oldest_alive conf base =
let limit = match p_getint conf.env "lim" with Some x -> x | _ -> 0 in
let get_oldest_alive p =
match get_death p with
| NotDead -> Date.od_of_cdate (get_birth p)
| DontKnowIfDead when limit > 0 -> (
match Date.od_of_cdate (get_birth p) with
| Some (Dgreg (d, _)) as x when conf.today.year - d.year <= limit -> x
| Some _ | None -> None)
| Death _ | DontKnowIfDead | DeadYoung | DeadDontKnowWhen | OfCourseDead ->
None
in
let list, len = select_person conf base get_oldest_alive true in
let title _ =
Printf.sprintf
(fcapitale (ftransl conf "the %d oldest perhaps still alive"))
len
|> Output.print_sstring conf
in
Hutil.header conf title;
Hutil.print_link_to_welcome conf true;
Output.print_sstring conf "<ul>\n";
List.iter
(fun (p, d, cal) ->
Output.print_sstring conf "<li><b>";
Output.print_string conf (referenced_person_text conf base p);
Output.print_sstring conf "</b>, ";
Output.print_sstring conf
(transl_nth conf "born" (index_of_sex (get_sex p)));
Output.print_sstring conf " <em>";
Output.print_string conf
(DateDisplay.string_of_ondate conf (Dgreg (d, cal)));
Output.print_sstring conf "</em>";
if get_death p = NotDead && d.prec = Sure then (
let a = Date.time_elapsed d conf.today in
Output.print_sstring conf " <em>(";
Output.print_string conf (DateDisplay.string_of_age conf a);
Output.print_sstring conf ")</em>");
Output.print_sstring conf ".</li>")
list;
Output.print_sstring conf "</ul>";
Hutil.trailer conf
let print_longest_lived conf base =
let get_longest p =
if Util.authorized_age conf base p then
match (Date.cdate_to_dmy_opt (get_birth p), get_death p) with
| Some bd, Death (_, cd) -> (
match Date.cdate_to_dmy_opt cd with
| None -> None
| Some dd -> Some (Dgreg (Date.time_elapsed bd dd, Dgregorian)))
| _ -> None
else None
in
let list, len = select_person conf base get_longest false in
let title _ =
Printf.sprintf (fcapitale (ftransl conf "the %d who lived the longest")) len
|> Output.print_sstring conf
in
Hutil.header conf title;
Hutil.print_link_to_welcome conf true;
Output.print_sstring conf "<ul>";
List.iter
(fun (p, d, _) ->
Output.print_sstring conf "<li><strong>";
Output.print_string conf (referenced_person_text conf base p);
Output.print_sstring conf "</strong>";
Output.print_string conf (DateDisplay.short_dates_text conf base p);
Output.print_sstring conf " (";
Output.print_sstring conf (string_of_int d.year);
Output.print_sstring conf " ";
Output.print_sstring conf (transl conf "years old");
Output.print_sstring conf ")";
Output.print_sstring conf ".";
Output.print_sstring conf "</li>")
list;
Output.print_sstring conf "</ul>";
Hutil.trailer conf
let print_marr_or_eng conf base title list =
Hutil.header conf title;
Hutil.print_link_to_welcome conf true;
Output.print_sstring conf "<ul>\n";
ignore
@@ List.fold_left
(fun (last_month_txt, was_future) (fam, d, cal) ->
let month_txt, future =
list_aux_1 conf d cal last_month_txt was_future
in
Output.print_sstring conf "<li><b>";
Output.print_string conf
(referenced_person_text conf base (pget conf base (get_father fam)));
Output.print_sstring conf "</b> ";
Output.print_sstring conf (transl_nth conf "and" 0);
Output.print_sstring conf " <b>";
Output.print_string conf
(referenced_person_text conf base (pget conf base (get_mother fam)));
Output.print_sstring conf "</b>, ";
if future then (
Output.print_sstring conf "<em>";
Output.print_string conf
(DateDisplay.string_of_date conf (Dgreg (d, cal)));
Output.print_sstring conf "</em>")
else (
(match get_relation fam with
| NotMarried | NoSexesCheckNotMarried ->
Output.print_sstring conf
@@ transl_nth conf "relation/relations" 0
| Married | NoSexesCheckMarried ->
Output.print_sstring conf @@ transl conf "married"
| Engaged -> Output.print_sstring conf @@ transl conf "engaged"
| MarriageBann | MarriageContract | MarriageLicense | Pacs
| Residence | NoMention ->
());
Output.print_sstring conf " <em>";
Output.print_string conf
(DateDisplay.string_of_ondate conf (Dgreg (d, cal)));
Output.print_sstring conf "</em>.");
Output.print_sstring conf "</li>";
(month_txt, future))
(Adef.safe "", false)
list;
Output.print_sstring conf "</ul></li>";
Hutil.trailer conf
let print_marriage conf base =
let list, len =
select_family conf base
(fun fam ->
let rel = get_relation fam in
if rel = Married || rel = NoSexesCheckMarried then
Date.od_of_cdate (get_marriage fam)
else None)
false
in
let title _ =
Printf.sprintf (fcapitale (ftransl conf "the latest %d marriages")) len
|> Output.print_sstring conf
in
print_marr_or_eng conf base title list
let print_oldest_engagements conf base =
let list, len =
select_family conf base
(fun fam ->
if get_relation fam = Engaged then
let husb = pget conf base (get_father fam) in
let wife = pget conf base (get_mother fam) in
match (get_death husb, get_death wife) with
| (NotDead | DontKnowIfDead), (NotDead | DontKnowIfDead) ->
Date.od_of_cdate (get_marriage fam)
| _ -> None
else None)
true
in
let title _ =
Printf.sprintf
(fcapitale
(ftransl conf "the %d oldest couples perhaps still alive and engaged"))
len
|> Output.print_sstring conf
in
print_marr_or_eng conf base title list
let old_print_statistics conf =
let title _ =
transl conf "statistics" |> Utf8.capitalize_fst |> Output.print_sstring conf
in
let n =
try int_of_string (List.assoc "latest_event" conf.base_env)
with Not_found | Failure _ -> 20
in
Hutil.header conf title;
Hutil.print_link_to_welcome conf true;
Output.print_sstring conf "<ul>";
let aux m label =
Output.print_sstring conf {|<li><a href="|};
Output.print_string conf (commd conf);
Output.print_sstring conf {|m=|};
Output.print_sstring conf m;
Output.print_sstring conf {|&k=|};
Output.print_sstring conf (string_of_int n);
Output.print_sstring conf {|">|};
Output.print_sstring conf (Printf.sprintf (ftransl conf label) n);
Output.print_sstring conf {|</a></li>|}
in
if conf.wizard || conf.friend then (
aux "LB" "the latest %d births";
aux "LD" "the latest %d deaths";
(* FIXME *)
aux "LM" "the latest %d marriages";
aux "OE" "the %d oldest couples perhaps still alive and engaged";
aux "OA" "the %d oldest perhaps still alive");
aux "LL" "the %d who lived the longest";
Output.print_sstring conf "</ul>\n";
Hutil.trailer conf
(* *)
type 'a env = Vother of 'a
let get_vother = function Vother x -> Some x
let set_vother x = Vother x
let print_statistics conf =
if p_getenv conf.env "old" = Some "on" then old_print_statistics conf
else
Hutil.interp conf "stats"
{
Templ.eval_var = (fun _ -> raise Not_found);
Templ.eval_transl = (fun _ -> Templ.eval_transl conf);
Templ.eval_predefined_apply = (fun _ -> raise Not_found);
Templ.get_vother;
Templ.set_vother;
Templ.print_foreach = (fun _ -> raise Not_found);
}
[] ()
let print_population_pyramid conf base =
let interval =
match p_getint conf.env "int" with Some i -> max 1 i | None -> 5
in
let limit = match p_getint conf.env "lim" with Some x -> x | _ -> 0 in
let at_date =
match p_getint conf.env "y" with
| Some i -> { year = i; month = 31; day = 12; prec = Sure; delta = 0 }
| None -> conf.today
in
let nb_intervals = 150 / interval in
let men, wom =
make_population_pyramid ~nb_intervals ~interval ~limit ~at_date conf base
in
let at_year = at_date.year in
let string_of_nb n =
Mutil.string_of_int_sep (transl conf "(thousand separator)") n
in
let title _ =
transl conf "population pyramid"
|> Utf8.capitalize_fst |> Output.print_sstring conf;
Output.print_sstring conf " (";
Output.print_sstring conf (string_of_int at_year);
Output.print_sstring conf ")"
in
let print_image doit sex iname =
Output.print_sstring conf "<td>";
if doit then (
Output.print_sstring conf {|<img src="|};
Output.print_sstring conf (Util.images_prefix conf);
Output.print_sstring conf "/";
Output.print_string conf iname;
Output.print_sstring conf {|" alt="|};
Output.print_sstring conf (transl_nth conf "M/F" sex);
Output.print_sstring conf {|" title="|};
Output.print_sstring conf (transl_nth conf "M/F" sex);
Output.print_sstring conf {|">|})
else Output.print_sstring conf "&nbsp;";
Output.print_sstring conf "</td>"
in
Hutil.header conf title;
Hutil.print_link_to_welcome conf true;
let max_hum =
let max_men = Array.fold_left max 0 men in
let max_wom = Array.fold_left max 0 wom in
max 1 (max max_men max_wom)
in
let max_size = 70 in
let band_size n = ((2 * max_size * n) + max_hum) / (2 * max_hum) in
let first_interv =
let rec loop i =
if i <= 0 then 0
else if men.(i) > 0 || wom.(i) > 0 then i
else loop (i - 1)
in
loop nb_intervals
in
Output.print_sstring conf "<div>\n";
Output.print_sstring conf {|<table id="table_pop_pyr" border="|};
Output.print_sstring conf (string_of_int conf.border);
Output.print_sstring conf
{|" cellspacing="0" cellpadding="0" style="margin:auto">|};
for i = first_interv downto 0 do
let nb_men = men.(i) in
let nb_wom = wom.(i) in
Output.print_sstring conf "<tr><td class=\"pyramid_year\">";
Output.print_sstring conf (string_of_int @@ (at_year - (i * interval)));
Output.print_sstring conf "</td><td>&nbsp;</td>";
print_image (i = 0) 0 (Adef.safe "male.png");
Output.print_sstring conf "<td>&nbsp;</td><td align=\"right\">\n";
Output.printf conf
{|<table cellspacing="0" cellpadding="0"><tr><td class="pyramid_nb">|};
if nb_men <> 0 then Output.print_sstring conf (string_of_int nb_men);
Output.print_sstring conf "&nbsp;</td><td>";
let aux_img nb img =
if nb <> 0 then (
let n = max 1 (band_size nb) in
Output.print_sstring conf {|<img src="|};
Output.print_string conf img;
Output.print_sstring conf {|" width="|};
Output.print_sstring conf (string_of_int @@ (n * 3));
Output.print_sstring conf {|" height="22">|})
in
aux_img nb_men
(Adef.encoded (Filename.concat (Util.images_prefix conf) "pyr_male.png"));
Output.print_sstring conf
{|</td></tr></table></td><td align="center" class="pyramid_center">|};
if i = nb_intervals then Output.print_sstring conf "&nbsp;"
else Output.print_sstring conf (string_of_int @@ ((i + 1) * interval));
Output.print_sstring conf
{|</td><td align="left"><table cellspacing="0" cellpadding="0"><tr><td>|};
aux_img nb_wom
(Adef.encoded
(Filename.concat (Util.images_prefix conf) "pyr_female.png"));
Output.print_sstring conf {|</td><td class="pyramid_nb">&nbsp;|};
if nb_wom <> 0 then Output.print_sstring conf (string_of_int nb_wom);
Output.print_sstring conf "</td></tr></table></td><td>&nbsp;</td>\n";
print_image (i = 0) 1 (Adef.safe "female.png");
Output.print_sstring conf {|<td>&nbsp;</td><td class="pyramid_year">|};
Output.print_sstring conf (string_of_int @@ (at_year - (i * interval)));
Output.print_sstring conf "</td></tr>"
done;
Output.print_sstring conf "</table>";
Output.print_sstring conf "</div><p>";
let sum_men = Array.fold_left ( + ) 0 men in
let sum_wom = Array.fold_left ( + ) 0 wom in
transl conf "number of living persons"
|> Utf8.capitalize_fst |> Output.print_sstring conf;
Output.print_sstring conf (transl conf ":");
Output.print_sstring conf " ";
Output.print_sstring conf (string_of_nb (sum_men + sum_wom));
Output.print_sstring conf {|.</p><form method="get" action="|};
Output.print_string conf (commd conf);
Output.print_sstring conf {|"><div class="form-inline">|};
hidden_env conf;
Util.hidden_input conf "m" (Adef.encoded "POP_PYR");
Output.print_sstring conf {|<label for="yr">|};
transl_nth conf "year/month/day" 0
|> Utf8.capitalize_fst |> Output.print_sstring conf;
Output.print_sstring conf "</label>";
Output.print_sstring conf {|<input type="number" id="yr" name="y" value="|};
Output.print_sstring conf (string_of_int at_year);
Output.print_sstring conf
{|" class="form-control col-1 ml-2" step="1">
<label for="int" class="ml-3">|};
transl conf "interval" |> Utf8.capitalize_fst |> Output.print_sstring conf;
Output.print_sstring conf
{|</label><input type="number" id="int" name="int" value="|};
Output.print_sstring conf (string_of_int interval);
Output.print_sstring conf
{|" class="form-control col-1 ml-2" step="1" min="0" max="130">
<label for="lim" class="ml-3">|};
transl conf "limit" |> Utf8.capitalize_fst |> Output.print_sstring conf;
Output.print_sstring conf
{|</label><input type="number" id="lim" name="lim" value="|};
Output.print_sstring conf (string_of_int limit);
Output.print_sstring conf
{|" class="form-control col-1 ml-2" step="1" min="0" max="|};
Output.print_sstring conf (string_of_nb (sum_men + sum_wom));
Output.print_sstring conf
{|"><button type="submit" class="btn btn-primary ml-3">OK</button>
</div></form>|};
Hutil.trailer conf

26
lib/birthDeathDisplay.mli Normal file
View File

@@ -0,0 +1,26 @@
val print_birth : Config.config -> Gwdb.base -> unit
(** Lists the last births *)
val print_death : Config.config -> Gwdb.base -> unit
(** Lists the last deaths *)
val print_longest_lived : Config.config -> Gwdb.base -> unit
(** Lists the persons who lived the longest *)
val print_oldest_alive : Config.config -> Gwdb.base -> unit
(** Displays the list of the oldest persons that are still alive or, if unknown,
whose death are not probable *)
val print_marriage : Config.config -> Gwdb.base -> unit
(** Lists the last marriages *)
val print_oldest_engagements : Config.config -> Gwdb.base -> unit
(** Displays the list of the oldest couples that still exist *)
val print_statistics : Config.config -> unit
(** Displays several links for statistics: latest births, death, marriages, the
oldest couples, persons that are alive and who lived the longest, as well as
a population pyramid *)
val print_population_pyramid : Config.config -> Gwdb.base -> unit
(** Displays a population pyramid from the base data *)

603
lib/birthdayDisplay.ml Normal file
View File

@@ -0,0 +1,603 @@
(* Copyright (c) 1998-2007 INRIA *)
open Config
open Def
open Gwdb
open Util
type date_event = DeBirth | DeDeath of death_reason
let print_age conf a_ref a =
Output.print_sstring conf " <em>";
Output.print_sstring conf (string_of_int a);
Output.print_sstring conf "</em>";
Output.print_sstring conf ", ";
match a_ref - a with
| 0 -> Output.print_sstring conf (transl conf "birth")
| 1 -> Output.print_sstring conf (transl conf "one year old")
| n ->
Output.print_sstring conf (string_of_int n);
Output.print_sstring conf " ";
Output.print_sstring conf (transl conf "years old")
let print_anniversary_day conf base dead_people liste =
let a_ref = conf.today.year in
Output.print_sstring conf "<ul>";
List.iter
(fun (p, a, date_event, txt_of) ->
let is = index_of_sex (get_sex p) in
Output.print_sstring conf "<li>";
Output.print_string conf (txt_of conf base p);
if not dead_people then print_age conf a_ref a
else (
Output.print_sstring conf ", <em>";
(Output.print_sstring conf
@@
match date_event with
| DeBirth -> transl_nth conf "born" is
| DeDeath Unspecified -> transl_nth conf "died" is
| DeDeath Killed -> transl_nth conf "killed (in action)" is
| DeDeath Murdered -> transl_nth conf "murdered" is
| DeDeath Executed -> transl_nth conf "executed (legally killed)" is
| DeDeath Disappeared -> transl_nth conf "disappeared" is);
Output.print_sstring conf " ";
Output.print_sstring conf (transl conf "in (year)");
Output.print_sstring conf " ";
Output.print_sstring conf (string_of_int a);
Output.print_sstring conf "</em>");
Output.print_sstring conf "</li>")
liste;
Output.print_sstring conf "</ul>"
let gen_print conf base mois f_scan dead_people =
let tab = Array.make 31 [] in
let title _ =
let lab =
if dead_people then transl conf "anniversaries"
else transl conf "birthdays"
in
Output.printf conf "%s %s" (Utf8.capitalize_fst lab)
(Util.translate_eval (transl_nth conf "(month)" (mois - 1)))
in
(try
while true do
let p, txt_of = f_scan () in
if not dead_people then
match (Date.cdate_to_dmy_opt (get_birth p), get_death p) with
| Some d, (NotDead | DontKnowIfDead) ->
if
d.prec = Sure && d.day <> 0 && d.month <> 0 && d.month = mois
&& d.delta = 0
then
if authorized_age conf base p then
let j = d.day in
tab.(pred j) <- (p, d.year, DeBirth, txt_of) :: tab.(pred j)
| _ -> ()
else
match get_death p with
| NotDead | DontKnowIfDead -> ()
| Death _ | DeadYoung | DeadDontKnowWhen | OfCourseDead -> (
(match Date.cdate_to_dmy_opt (get_birth p) with
| None -> ()
| Some dt ->
if
dt.prec = Sure && dt.day <> 0 && dt.month <> 0
&& dt.month = mois && dt.delta = 0
then
if authorized_age conf base p then
let j = dt.day in
tab.(pred j) <-
(p, dt.year, DeBirth, txt_of) :: tab.(pred j));
match get_death p with
| NotDead | DeadYoung | DeadDontKnowWhen | DontKnowIfDead
| OfCourseDead ->
()
| Death (dr, d) -> (
match Date.cdate_to_dmy_opt d with
| None -> ()
| Some dt ->
if
dt.prec = Sure && dt.day <> 0 && dt.month <> 0
&& dt.month = mois && dt.delta = 0
then
if authorized_age conf base p then
let j = dt.day in
let a = dt.year in
tab.(pred j) <-
(p, a, DeDeath dr, txt_of) :: tab.(pred j)))
done
with Not_found -> ());
Hutil.header conf title;
if Array.for_all (( = ) []) tab then (
Output.print_sstring conf "<p>\n";
Output.printf conf "%s.\n"
(Utf8.capitalize_fst (transl conf "no anniversary"));
Output.print_sstring conf "</p>\n");
Output.print_sstring conf "<ul>\n";
for j = 1 to 31 do
if tab.(pred j) <> [] then (
Output.print_sstring conf "<li>\n";
Output.printf conf "%d\n" j;
(let liste =
List.sort
(fun (_, a1, _, _) (_, a2, _, _) -> compare a1 a2)
tab.(pred j)
in
print_anniversary_day conf base dead_people liste);
Output.print_sstring conf "</li>\n")
done;
Output.print_sstring conf "</ul>\n";
Hutil.trailer conf
let print_anniversary_list conf base dead_people dt liste =
let a_ref = dt.year in
Output.print_sstring conf "<ul>\n";
List.iter
(fun (p, a, date_event, txt_of) ->
Output.print_sstring conf "<li>";
if dead_people then (
Output.print_sstring conf "<em>";
(match date_event with
| DeBirth -> Output.print_sstring conf (transl conf "birth")
| DeDeath _ -> Output.print_sstring conf (transl conf "death"));
Output.print_sstring conf "</em> -&gt; ";
Output.print_string conf (txt_of conf base p);
Output.print_sstring conf " <em>";
Output.print_sstring conf (transl conf "in (year)");
Output.print_sstring conf " ";
Output.print_sstring conf (string_of_int a);
Output.print_sstring conf " (";
Output.print_sstring conf
(Printf.sprintf (ftransl conf "%d years ago") (conf.today.year - a));
Output.print_sstring conf ")</em>")
else (
Output.print_string conf (txt_of conf base p);
(* TODO year of birth *)
match get_death p with NotDead -> print_age conf a_ref a | _ -> ());
Output.print_sstring conf "</li>")
liste;
Output.print_sstring conf "</ul>"
let f_scan conf base =
let next = Gwdb.Collection.iterator (Gwdb.ipers base) in
fun () ->
match next () with
| Some i -> (pget conf base i, referenced_person_title_text)
| None -> raise Not_found
let print_birth conf base mois =
gen_print conf base mois (f_scan conf base) false
let print_dead conf base mois = gen_print conf base mois (f_scan conf base) true
let print_birth_day conf base day_name fphrase wd dt list =
match list with
| [] ->
Output.print_sstring conf "<p>";
Output.print_sstring conf
(Utf8.capitalize_fst (transl conf "no birthday"));
Output.print_sstring conf " ";
Output.print_string conf day_name;
Output.print_sstring conf ".</p>"
| _ ->
Output.print_sstring conf "<p>\n";
let txt =
transl_nth conf "(week day)" wd ^ " " ^ DateDisplay.code_dmy conf dt
|> transl_decline conf "on (weekday day month year)"
|> Adef.safe
in
Output.printf conf fphrase
(Utf8.capitalize_fst (day_name : Adef.safe_string :> string)
^<^ ",\n"
^<^ std_color conf ("<b>" ^<^ txt ^>^ "</b>")
: Adef.safe_string
:> string)
(transl conf "the birthday");
Output.print_sstring conf "...</p>";
print_anniversary_list conf base false dt list
let propose_months conf mode =
begin_centered conf;
Output.print_sstring conf "<span>";
transl conf "select a month to see all the anniversaries"
|> Utf8.capitalize_fst |> Output.print_sstring conf;
Output.print_sstring conf "</span>";
Output.print_sstring conf {|<table border="|};
Output.print_sstring conf (string_of_int conf.border);
Output.print_sstring conf {|"><tr><td>|};
Output.print_sstring conf {|<form class="form-inline" method="get" action="|};
Output.print_sstring conf conf.command;
Output.print_sstring conf {|"><p>|};
Util.hidden_env conf;
mode ();
Output.print_sstring conf
{|<select class="form-control form-control-lg" name="v">|};
for i = 1 to 12 do
Output.print_sstring conf {|<option value="|};
Output.print_sstring conf (string_of_int i);
Output.print_sstring conf {|"|};
Output.print_sstring conf
(if i = conf.today.month then {| selected="selected">|} else ">");
transl_nth conf "(month)" (i - 1)
|> Util.translate_eval |> Utf8.capitalize_fst |> Output.print_sstring conf;
Output.print_sstring conf "</option>"
done;
Output.print_sstring conf "</select>";
Output.print_sstring conf
{|<button type="submit" class="btn btn-primary btn-lg ml-2">|};
transl_nth conf "validate/delete" 0
|> Utf8.capitalize_fst |> Output.print_sstring conf;
Output.print_sstring conf "</button></p></form></td></tr></table>";
end_centered conf
let day_after d =
let day, r =
if d.day >= Date.nb_days_in_month d.month d.year then (1, 1)
else (succ d.day, 0)
in
let month, r = if d.month + r > 12 then (1, 1) else (d.month + r, 0) in
let year = d.year + r in
{ day; month; year; prec = Sure; delta = 0 }
let print_anniv conf base day_name fphrase wd dt = function
| [] ->
Output.print_sstring conf "<p>";
transl conf "no anniversary"
|> Utf8.capitalize_fst |> Output.print_sstring conf;
Output.print_sstring conf " ";
Output.print_string conf day_name;
Output.print_sstring conf ".</p>"
| list ->
Output.print_sstring conf "<p>";
let txt =
transl_nth conf "(week day)" wd ^ " " ^ DateDisplay.code_dmy conf dt
|> transl_decline conf "on (weekday day month year)"
|> Adef.safe
in
Output.printf conf fphrase
(Utf8.capitalize_fst (day_name : Adef.safe_string :> string)
^<^ ",\n"
^<^ std_color conf ("<b>" ^<^ txt ^>^ "</b>")
: Adef.safe_string
:> string)
(transl conf "the anniversary");
Output.print_sstring conf "...</p>";
print_anniversary_list conf base true dt list
let list_aux conf base list cb =
Output.print_sstring conf "<ul>";
List.iter
(fun (fam, year) ->
Output.print_sstring conf "<li>";
Output.print_string conf
(referenced_person_title_text conf base
(pget conf base (get_father fam)));
Output.print_sstring conf " ";
Output.print_sstring conf (transl_nth conf "and" 0);
Output.print_sstring conf " ";
Output.print_string conf
(referenced_person_title_text conf base
(pget conf base (get_mother fam)));
Output.print_sstring conf ", <em>";
Output.print_sstring conf (transl conf "in (year)");
Output.print_sstring conf " ";
Output.print_sstring conf (string_of_int year);
cb conf year;
Output.print_sstring conf "</em></li>")
list;
Output.print_sstring conf "</ul>"
let print_marriage conf base month =
let title _ =
let lab = transl conf "anniversaries of marriage" in
Output.printf conf "%s %s" (Utf8.capitalize_fst lab)
(transl_decline conf "in (month year)"
(transl_nth conf "(month)" (month - 1)))
in
let tab = Array.make 31 [] in
Hutil.header conf title;
Gwdb.Collection.iter
(fun ifam ->
let fam = foi base ifam in
match Date.cdate_to_dmy_opt (get_marriage fam) with
| Some { day = d; month = m; year = y; prec = Sure } when d <> 0 && m <> 0
->
let father = pget conf base (get_father fam) in
let mother = pget conf base (get_mother fam) in
if
m = month
&& authorized_age conf base father
&& (not (is_hidden father))
&& authorized_age conf base mother
&& not (is_hidden mother)
then tab.(pred d) <- (fam, y) :: tab.(pred d)
| _ -> ())
(Gwdb.ifams base);
Output.print_sstring conf "<ul>";
for i = 1 to 31 do
match tab.(i - 1) with
| [] -> ()
| list ->
let list = List.sort (fun (_, y1) (_, y2) -> compare y1 y2) list in
Output.print_sstring conf " <li>";
Output.print_sstring conf (string_of_int i);
list_aux conf base list (fun _ _ -> ());
Output.print_sstring conf " </li>"
done;
Output.print_sstring conf "</ul>";
Hutil.trailer conf
let print_anniversaries_of_marriage conf base list =
list_aux conf base list (fun conf year ->
Output.print_sstring conf " (";
Printf.sprintf (ftransl conf "%d years ago") (conf.today.year - year)
|> Output.print_sstring conf;
Output.print_sstring conf ")")
let print_marriage_day conf base day_name fphrase wd dt = function
| [] ->
Output.print_sstring conf "<p>";
transl conf "no anniversary"
|> Utf8.capitalize_fst |> Output.print_sstring conf;
Output.print_sstring conf " ";
Output.print_string conf day_name;
Output.print_sstring conf ".</p>"
| list ->
Output.print_sstring conf "<p>";
Output.printf conf fphrase
(Utf8.capitalize_fst (day_name : Adef.safe_string :> string)
^<^ ",\n"
^<^ std_color conf
("<b>"
^ transl_decline conf "on (weekday day month year)"
(transl_nth conf "(week day)" wd
^ " "
^ DateDisplay.code_dmy conf dt)
^ "</b>"
|> Adef.safe)
: Adef.safe_string
:> string)
(transl conf "the anniversary of marriage");
Output.print_sstring conf "...</p>";
print_anniversaries_of_marriage conf base list
let match_dates conf base p d1 d2 =
if d1.day = d2.day && d1.month = d2.month then authorized_age conf base p
else if
d1.day = 29 && d1.month = 2 && d2.day = 1 && d2.month = 3
&& not (Date.leap_year d2.year)
then authorized_age conf base p
else false
let gen_print_menu_birth conf base f_scan mode =
let title _ =
transl conf "birthdays" |> Utf8.capitalize_fst |> Output.print_sstring conf
in
let tom = day_after conf.today in
let aft = day_after tom in
let list_tod = ref [] in
let list_tom = ref [] in
let list_aft = ref [] in
(match Util.find_person_in_env conf base "" with
| Some p ->
Perso.interp_notempl_with_menu title "perso_header" conf base p;
Output.print_sstring conf "<h2>";
title false;
Output.print_sstring conf "</h2>"
| None -> Hutil.header conf title);
(try
while true do
let p, txt_of = f_scan () in
match (Date.cdate_to_dmy_opt (get_birth p), get_death p) with
| Some d, (NotDead | DontKnowIfDead) ->
if d.prec = Sure && d.day <> 0 && d.month <> 0 then
if match_dates conf base p d conf.today then
list_tod := (p, d.year, DeBirth, txt_of) :: !list_tod
else if match_dates conf base p d tom then
list_tom := (p, d.year, DeBirth, txt_of) :: !list_tom
else if match_dates conf base p d aft then
list_aft := (p, d.year, DeBirth, txt_of) :: !list_aft
| _ -> ()
done
with Not_found -> ());
List.iter
(fun xx ->
xx := List.sort (fun (_, a1, _, _) (_, a2, _, _) -> compare a1 a2) !xx)
[ list_tod; list_tom; list_aft ];
print_birth_day conf base
(transl conf "today" |> Adef.safe)
(ftransl conf "%s, it is %s of")
conf.today_wd conf.today !list_tod;
print_birth_day conf base
(transl conf "tomorrow" |> Adef.safe)
(ftransl conf "%s, it will be %s of")
((conf.today_wd + 1) mod 7)
tom !list_tom;
print_birth_day conf base
(transl conf "the day after tomorrow" |> Adef.safe)
(ftransl conf "%s, it will be %s of")
((conf.today_wd + 2) mod 7)
aft !list_aft;
Output.print_sstring conf " ";
propose_months conf mode;
Output.print_sstring conf " ";
Hutil.trailer conf
let print_menu_birth conf base =
let f_scan =
let next = Gwdb.Collection.iterator (Gwdb.ipers base) in
fun () ->
match next () with
| Some i -> (pget conf base i, referenced_person_title_text)
| None -> raise Not_found
in
let mode () =
Output.print_sstring conf
"<input type=\"hidden\" name=\"m\" value=\"AN\">\n"
in
gen_print_menu_birth conf base f_scan mode
let gen_print_menu_dead conf base f_scan mode =
let title _ =
transl conf "anniversaries of dead people"
|> Utf8.capitalize_fst |> Output.print_sstring conf
in
let tom = day_after conf.today in
let aft = day_after tom in
let list_tod = ref [] in
let list_tom = ref [] in
let list_aft = ref [] in
Hutil.header conf title;
(try
while true do
let p, txt_of = f_scan () in
match get_death p with
| NotDead | DontKnowIfDead -> ()
| Death _ | DeadYoung | DeadDontKnowWhen | OfCourseDead -> (
(match Date.cdate_to_dmy_opt (get_birth p) with
| None -> ()
| Some d ->
if d.prec = Sure && d.day <> 0 && d.month <> 0 then
if match_dates conf base p d conf.today then
list_tod := (p, d.year, DeBirth, txt_of) :: !list_tod
else if match_dates conf base p d tom then
list_tom := (p, d.year, DeBirth, txt_of) :: !list_tom
else if match_dates conf base p d aft then
list_aft := (p, d.year, DeBirth, txt_of) :: !list_aft);
match get_death p with
| Death (dr, d) -> (
match Date.cdate_to_dmy_opt d with
| None -> ()
| Some d ->
if d.prec = Sure && d.day <> 0 && d.month <> 0 then
if match_dates conf base p d conf.today then
list_tod := (p, d.year, DeDeath dr, txt_of) :: !list_tod
else if match_dates conf base p d tom then
list_tom := (p, d.year, DeDeath dr, txt_of) :: !list_tom
else if match_dates conf base p d aft then
list_aft := (p, d.year, DeDeath dr, txt_of) :: !list_aft)
| NotDead | DeadYoung | DeadDontKnowWhen | DontKnowIfDead
| OfCourseDead ->
())
done
with Not_found -> ());
List.iter
(fun xx ->
xx := List.sort (fun (_, a1, _, _) (_, a2, _, _) -> compare a1 a2) !xx)
[ list_tod; list_tom; list_aft ];
print_anniv conf base
(transl conf "today" |> Adef.safe)
(ftransl conf "%s, it is %s of")
conf.today_wd conf.today !list_tod;
print_anniv conf base
(transl conf "tomorrow" |> Adef.safe)
(ftransl conf "%s, it will be %s of")
((conf.today_wd + 1) mod 7)
tom !list_tom;
print_anniv conf base
(transl conf "the day after tomorrow" |> Adef.safe)
(ftransl conf "%s, it will be %s of")
((conf.today_wd + 2) mod 7)
aft !list_aft;
Output.print_sstring conf "\n";
propose_months conf mode;
Output.print_sstring conf "\n";
Hutil.trailer conf
let print_menu_dead conf base =
let f_scan =
let next = Gwdb.Collection.iterator (Gwdb.ipers base) in
fun () ->
match next () with
| Some i -> (pget conf base i, referenced_person_title_text)
| None -> raise Not_found
in
gen_print_menu_dead conf base f_scan (fun () ->
Util.hidden_input conf "m" @@ Adef.encoded "AD")
let match_mar_dates conf base cpl d1 d2 =
if d1.day = d2.day && d1.month = d2.month then
authorized_age conf base (pget conf base (get_father cpl))
&& authorized_age conf base (pget conf base (get_mother cpl))
else if
d1.day = 29 && d1.month = 2 && d2.day = 1 && d2.month = 3
&& not (Date.leap_year d2.year)
then
authorized_age conf base (pget conf base (get_father cpl))
&& authorized_age conf base (pget conf base (get_mother cpl))
else false
let print_menu_marriage conf base =
let title _ =
transl conf "anniversaries of marriage"
|> Utf8.capitalize_fst |> Output.print_sstring conf
in
let tom = day_after conf.today in
let aft = day_after tom in
let list_tod = ref [] in
let list_tom = ref [] in
let list_aft = ref [] in
Hutil.header conf title;
Gwdb.Collection.iter
(fun ifam ->
let fam = foi base ifam in
match (Date.cdate_to_dmy_opt (get_marriage fam), get_divorce fam) with
| Some d, NotDivorced when d.day <> 0 && d.month <> 0 && d.prec = Sure ->
let update_list cpl =
if match_mar_dates conf base cpl d conf.today then
list_tod := (cpl, d.year) :: !list_tod
else if match_mar_dates conf base cpl d tom then
list_tom := (cpl, d.year) :: !list_tom
else if match_mar_dates conf base cpl d aft then
list_aft := (cpl, d.year) :: !list_aft
in
if conf.use_restrict then (
let father = pget conf base (get_father fam) in
let mother = pget conf base (get_mother fam) in
if (not (is_hidden father)) && not (is_hidden mother) then
update_list fam)
else update_list fam
| _ -> ())
(Gwdb.ifams base);
List.iter
(fun xx -> xx := List.sort (fun (_, y1) (_, y2) -> compare y1 y2) !xx)
[ list_tod; list_tom; list_aft ];
print_marriage_day conf base
(transl conf "today" |> Adef.safe)
(ftransl conf "%s, it is %s of")
conf.today_wd conf.today !list_tod;
print_marriage_day conf base
(transl conf "tomorrow" |> Adef.safe)
(ftransl conf "%s, it will be %s of")
((conf.today_wd + 1) mod 7)
tom !list_tom;
print_marriage_day conf base
(transl conf "the day after tomorrow" |> Adef.safe)
(ftransl conf "%s, it will be %s of")
((conf.today_wd + 2) mod 7)
aft !list_aft;
Output.print_sstring conf "\n";
propose_months conf (fun () ->
Util.hidden_input conf "m" @@ Adef.encoded "AM");
Output.print_sstring conf "\n";
Hutil.trailer conf
(* template *)
type 'a env = Vother of 'a
let get_vother = function Vother x -> Some x
let set_vother x = Vother x
let print_anniversaries conf =
if p_getenv conf.env "old" = Some "on" then ()
else
Hutil.interp conf "annivmenu"
{
Templ.eval_var = (fun _ -> raise Not_found);
Templ.eval_transl = (fun _ -> Templ.eval_transl conf);
Templ.eval_predefined_apply = (fun _ -> raise Not_found);
Templ.get_vother;
Templ.set_vother;
Templ.print_foreach = (fun _ -> raise Not_found);
}
[] ()

67
lib/birthdayDisplay.mli Normal file
View File

@@ -0,0 +1,67 @@
val gen_print :
Config.config ->
Gwdb.base ->
int ->
(unit ->
Gwdb.person * (Config.config -> Gwdb.base -> Gwdb.person -> Adef.safe_string)) ->
bool ->
unit
(** [gen_print conf base month (next,txt_of) dead_people] displays anniversaries
for a given month separated by day.
If [dead_people] is true then displays birth/death anniversaries for dead people with death reason.
Otherwise displays birthdays for alive people.
[next] is function that returns next person from iterator
and [txt_of] text/link that describes person's information *)
val print_birth : Config.config -> Gwdb.base -> int -> unit
(** Displays birthdays for alive people for a given month *)
val print_dead : Config.config -> Gwdb.base -> int -> unit
(** Displays anniversaries for dead people for a given month *)
val print_marriage : Config.config -> Gwdb.base -> int -> unit
(** Displays marriage anniversaries for a given month *)
val gen_print_menu_birth :
Config.config ->
Gwdb.base ->
(unit ->
Gwdb.person * (Config.config -> Gwdb.base -> Gwdb.person -> Adef.safe_string)) ->
(unit -> unit) ->
unit
(** [gen_print_menu_birth conf base (next,txt_of) mode] displays the main birthdays menu for alive people
that contains:
- Persons that has their birthdays today
- Persons that has their birthdays tomorrow
- Persons that has their birthdays after today
- Form to select the month of birthdays we want to see.
[next] is function that returns next person from iterator, [txt_of] text/link that
describes person's information and [mode] that add some additional hidden inputs in the month form *)
val print_menu_birth : Config.config -> Gwdb.base -> unit
(** Displays the main birthdays menu considering all alive people *)
val gen_print_menu_dead :
Config.config ->
Gwdb.base ->
(unit ->
Gwdb.person * (Config.config -> Gwdb.base -> Gwdb.person -> Adef.safe_string)) ->
(unit -> unit) ->
unit
(** [gen_print_menu_dead conf base (next,txt_of) mode] displays the main anniversaries menu for dead people
that contains:
- Persons that has their anniversaries today
- Persons that has their anniversaries tomorrow
- Persons that has their anniversaries after today
- Form to select the month of anniversaries we want to see.
[next] is function that returns next person from iterator, [txt_of] text/link that
describes person's information and [mode] that add some additional hidden inputs in the month form *)
val print_menu_dead : Config.config -> Gwdb.base -> unit
(** Displays the main anniversaries menu considering all dead people *)
val print_menu_marriage : Config.config -> Gwdb.base -> unit
(** Displays the main wedding anniversaries menu *)
val print_anniversaries : Config.config -> unit
(** Displays the menu of anniversaries selection *)

91
lib/changeChildren.ml Normal file
View File

@@ -0,0 +1,91 @@
(* Copyright (c) 1998-2007 INRIA *)
open Config
open Def
open Gwdb
open Util
let digest_children base ipl =
List.fold_left
(fun _s ip ->
let p = poi base ip in
sou base (get_first_name p)
^ "\n"
^ sou base (get_surname p)
^ "\n"
^ string_of_int (get_occ p)
^ "\n")
"" ipl
|> Mutil.digest
let check_digest conf digest =
match p_getenv conf.env "digest" with
| Some ini_digest -> if digest <> ini_digest then Update.error_digest conf
| None -> ()
exception ChangeChildrenConflict of person * person
exception FirstNameMissing of iper
let check_conflict base p key new_occ ipl =
let name = Name.lower key in
List.iter
(fun ip ->
let p1 = poi base ip in
if
get_iper p1 <> get_iper p
&& Name.lower (p_first_name base p1 ^ " " ^ p_surname base p1) = name
&& get_occ p1 = new_occ
then raise @@ ChangeChildrenConflict (p, p1))
ipl
let change_child conf base parent_surname changed ip =
let p = poi base ip in
let var = "c" ^ string_of_iper (get_iper p) in
let new_first_name =
match p_getenv conf.env (var ^ "_first_name") with
| Some x -> only_printable x
| _ -> p_first_name base p
in
let new_surname =
match p_getenv conf.env (var ^ "_surname") with
| Some x ->
let x = only_printable x in
if x = "" then parent_surname else x
| _ -> p_surname base p
in
let new_occ =
match p_getint conf.env (var ^ "_occ") with Some x -> x | _ -> 0
in
if new_first_name = "" then raise (FirstNameMissing ip)
else if
new_first_name <> p_first_name base p
|| new_surname <> p_surname base p
|| new_occ <> get_occ p
then (
let key = new_first_name ^ " " ^ new_surname in
let ipl = Gutil.person_ht_find_all base key in
check_conflict base p key new_occ ipl;
Image.rename_portrait conf base p (new_first_name, new_surname, new_occ);
(* On ajoute les enfants dans le type Change_children_name *)
(* pour la future mise à jour de l'historique et du fichier gwf. *)
let changed =
( (p_first_name base p, p_surname base p, get_occ p, ip),
(new_first_name, new_surname, new_occ, ip) )
:: changed
in
let p =
{
(gen_person_of_person p) with
first_name = Gwdb.insert_string base new_first_name;
surname = Gwdb.insert_string base new_surname;
occ = new_occ;
}
in
patch_person base ip p;
changed)
else changed
let change_children conf base parent_surname =
List.fold_left
(fun changed ip -> change_child conf base parent_surname changed ip)
[]

25
lib/changeChildren.mli Normal file
View File

@@ -0,0 +1,25 @@
val digest_children : Gwdb.base -> Gwdb.iper list -> string
(** Returns digest (using md5 algorithm) of concatenated for every children first name, surname and occurence number *)
val check_digest : Config.config -> string -> unit
(** Checks if children digest in environement [conf.env] corresponds to specified digest. Other print error page. *)
exception ChangeChildrenConflict of Gwdb.person * Gwdb.person
(** Exception raised when children change defines a new children information (new first name, new surname and new occurence number) are in
conflict with another person already existing in the base *)
exception FirstNameMissing of Gwdb.iper
(** Exception raised when children change removes it first name *)
val change_children :
Config.config ->
Gwdb.base ->
string ->
Gwdb.iper list ->
((string * string * int * Gwdb.iper) * (string * string * int * Gwdb.iper))
list
(** Change all person's children by looking up information to update inside [conf.env] that was send by the form.
Changes also children's personal image name. Could raise [ChangeChildrenConflict] if new children's key
is in conflict with another and [FirstNameMissing] if new children's first name is empty. If surname modification is
requested but absent then children takes parent's surname. Returns informations used by [Update] module to record
children's update operation. *)

208
lib/changeChildrenDisplay.ml Normal file
View File

@@ -0,0 +1,208 @@
(* Copyright (c) 1998-2007 INRIA *)
open Config
open Def
open Gwdb
open Util
open ChangeChildren
let print_child_person conf base p =
let var = Adef.encoded ("c" ^ string_of_iper (get_iper p)) in
let first_name =
match p_getenv conf.env ((var :> string) ^ "_first_name") with
| Some v -> v
| None -> p_first_name base p
in
let surname =
match p_getenv conf.env ((var :> string) ^ "_surname") with
| Some v -> v
| None -> p_surname base p
in
let occ =
match p_getint conf.env ((var :> string) ^ "_occ") with
| Some i -> i
| None -> get_occ p
in
Output.print_sstring conf {|<table class="m1-2"><tbody><tr align="|};
Output.print_sstring conf conf.left;
Output.print_sstring conf {|"><td>|};
Output.print_sstring conf {|<label for="|};
Output.print_string conf var;
Output.print_sstring conf {|_fn" class="mx-2 mb-0">|};
transl_nth conf "first name/first names" 0
|> Utf8.capitalize_fst |> Output.print_sstring conf;
Output.print_sstring conf {|</label></td><td colspan="3">|};
Output.print_sstring conf {|<input name=\"|};
Output.print_string conf var;
Output.print_sstring conf
{|_first_name" class="form-control" size="23" maxlength="200" id="|};
Output.print_string conf var;
Output.print_sstring conf {|_fn" value="|};
Output.print_string conf (Util.escape_html first_name);
Output.print_sstring conf {|">|};
Output.print_sstring conf {|</td><td align="|};
Output.print_sstring conf conf.right;
Output.print_sstring conf {|"><label for="|};
Output.print_string conf var;
Output.print_sstring conf {|_occ" class="mx-2 mb-0">|};
transl conf "number" |> Utf8.capitalize_fst |> Output.print_sstring conf;
Output.print_sstring conf {|</label></td><td>|};
Output.print_sstring conf {|<input class="form-control" id="|};
Output.print_string conf var;
Output.print_sstring conf {|_occ" name="|};
Output.print_string conf var;
Output.print_sstring conf {|occ" size="5" maxlength="8"|};
Output.print_sstring conf
(if occ = 0 then "" else {| value="|} ^ string_of_int occ ^ {|"|});
Output.print_sstring conf {|</td></tr><tr align="|};
Output.print_sstring conf conf.left;
Output.print_sstring conf {|"><td>|};
Output.print_sstring conf {|<label for="|};
Output.print_string conf var;
Output.print_sstring conf {|_sn" class="mx-2 mb-0">|};
transl_nth conf "surname/surnames" 0
|> Utf8.capitalize_fst |> Output.print_sstring conf;
Output.print_sstring conf {|</label></td><td colspan="5">|};
Output.print_sstring conf {|<input name="|};
Output.print_string conf var;
Output.print_sstring conf
{|_surname" class="form-control" size="40" maxlength="200" id="|};
Output.print_string conf var;
Output.print_sstring conf {|_sn" value="|};
Output.print_string conf (Util.escape_html surname);
Output.print_sstring conf {|">|};
Output.print_sstring conf {|</td></tr></tbody></table>|}
let print_children conf base ipl =
Output.print_sstring conf "<ul>\n";
List.iter
(fun ip ->
let p = poi base ip in
Output.print_sstring conf {|<li class="mt-3"><span class="ml-2">|};
Output.print_string conf
(reference conf base p (gen_person_text conf base p));
Output.print_string conf (DateDisplay.short_dates_text conf base p);
Output.print_sstring conf {|</span>|};
print_child_person conf base p;
Output.print_sstring conf "</li>")
ipl;
Output.print_sstring conf "</ul>"
let print_change conf base p =
let title _ =
transl conf "change children's names"
|> Utf8.capitalize_fst |> Output.print_sstring conf
in
let children = children_of_p base p in
let digest = digest_children base children in
Perso.interp_notempl_with_menu title "perso_header" conf base p;
Output.print_sstring conf "<h2>";
title false;
(let s : Adef.safe_string = gen_person_text conf base p in
let r : Adef.safe_string = reference conf base p s in
Util.transl_a_of_b conf "" (r :> string) (s :> string)
|> Output.print_sstring conf);
Output.print_sstring conf " ";
Output.print_string conf (DateDisplay.short_dates_text conf base p);
Output.print_sstring conf {|</h2><form method="post" action="|};
Output.print_sstring conf conf.command;
Output.print_sstring conf {|">|};
Util.hidden_env conf;
Util.hidden_input_s conf "ip" (string_of_iper (get_iper p));
Util.hidden_input_s conf "digest" digest;
Util.hidden_input_s conf "m" "CHG_CHN_OK";
print_children conf base children;
Output.print_sstring conf
{|<button type="submit" class="btn btn-primary btn-lg ml-5 mb-2">|};
transl_nth conf "validate/delete" 0
|> Utf8.capitalize_fst |> Output.print_sstring conf;
Output.print_sstring conf "</button></form>";
Hutil.trailer conf
let print conf base =
match p_getenv conf.env "ip" with
| Some i ->
let p = poi base (iper_of_string i) in
print_change conf base p
| _ -> Hutil.incorrect_request conf
let print_children_list conf base u =
Output.print_sstring conf "<h4>";
transl_nth conf "child/children" 1
|> Utf8.capitalize_fst |> Output.print_sstring conf;
Output.print_sstring conf "</h4><p><ul>";
Array.iter
(fun ifam ->
let des = foi base ifam in
Array.iter
(fun ip ->
let p = poi base ip in
Output.print_sstring conf "<li>";
gen_person_text conf base p
|> reference conf base p |> Output.print_string conf;
Output.print_string conf (DateDisplay.short_dates_text conf base p))
(get_children des))
(get_family u);
Output.print_sstring conf "</ul>"
let print_change_done conf base p =
let title _ =
transl conf "children's names changed"
|> Utf8.capitalize_fst |> Output.print_sstring conf
in
Hutil.header conf title;
gen_person_text conf base p
|> reference conf base p |> Output.print_string conf;
Output.print_string conf (DateDisplay.short_dates_text conf base p);
print_children_list conf base p;
Hutil.trailer conf
let print_conflict conf base ip_var p =
let var = "c" ^ string_of_iper ip_var in
Update.print_create_conflict conf base p var
let error_person conf err =
let title _ =
transl conf "error" |> Utf8.capitalize_fst |> Output.print_sstring conf
in
Hutil.rheader conf title;
Output.printf conf "%s\n" (Utf8.capitalize_fst err);
Hutil.trailer conf;
raise
@@ Update.ModErr
(Update.UERR (__FILE__ ^ " " ^ string_of_int __LINE__ |> Adef.safe))
let print_update_child conf base =
match p_getenv conf.env "m" with
| Some "CHG_CHN_OK" -> print conf base
| _ -> Hutil.incorrect_request conf
let print_change_ok conf base p =
let ipl = children_of_p base p in
let parent_surname = p_surname base p in
let redisp = Option.is_some (p_getenv conf.env "return") in
if redisp then print_update_child conf base
else (
check_digest conf (digest_children base ipl);
let changed =
try change_children conf base parent_surname ipl with
| ChangeChildrenConflict (p, p') ->
print_conflict conf base (get_iper p) p'
| FirstNameMissing _ ->
error_person conf (transl conf "first name missing")
in
Util.commit_patches conf base;
let changed =
U_Change_children_name
(Util.string_gen_person base (gen_person_of_person p), changed)
in
History.record conf base changed "cn";
print_change_done conf base p)
let print_ok o_conf base =
let conf = Update.update_conf o_conf in
match p_getenv conf.env "ip" with
| Some i ->
let p = poi base (iper_of_string i) in
print_change_ok conf base p
| _ -> Hutil.incorrect_request conf

8
lib/changeChildrenDisplay.mli Normal file
View File

@@ -0,0 +1,8 @@
val print : Config.config -> Gwdb.base -> unit
(** Displays a form where all person's children with their first names, surnames and occurence numbers are listed
and could be modified on submit. Id of person should be mentionned in environement [conf.env] with binding {i "ip"=id}
otherwise displays Bad request page. *)
val print_ok : Config.config -> Gwdb.base -> unit
(** Performs and displays results of children modification requested by form submiting. If changes of one of children raises an error
displays corresponding error page that either just informs user about error source either propose to fix up solution. *)

349
lib/check.ml Normal file
View File

@@ -0,0 +1,349 @@
(* $Id: check.ml,v 5.28 2008-11-03 15:40:10 ddr Exp $ *)
(* Copyright (c) 1998-2007 INRIA *)
open Def
open Gwdb
(* Printing check errors *)
let designation base p =
let s = Gutil.designation base p in
if String.get s 0 = '?' || String.get s (String.length s - 1) = '?' then
s ^ " (i=" ^ string_of_iper (get_iper p) ^ ")"
else s
let string_of_epers_name base epers_name =
match epers_name with
| Epers_Birth -> "birth"
| Epers_Baptism -> "baptism"
| Epers_Death -> "death"
| Epers_Burial -> "burial"
| Epers_Cremation -> "cremation"
| Epers_Accomplishment -> "accomplishment"
| Epers_Acquisition -> "acquisition"
| Epers_Adhesion -> "adhesion"
| Epers_BaptismLDS -> "baptism (LDS)"
| Epers_BarMitzvah -> "bar mitzvah"
| Epers_BatMitzvah -> "bat mitzvah"
| Epers_Benediction -> "benediction"
| Epers_ChangeName -> "change name"
| Epers_Circumcision -> "circumcision"
| Epers_Confirmation -> "confirmation"
| Epers_ConfirmationLDS -> "confirmation (LDS)"
| Epers_Decoration -> "decoration"
| Epers_DemobilisationMilitaire -> "military demobilisation"
| Epers_Diploma -> "diploma"
| Epers_Distinction -> "distinction"
| Epers_Dotation -> "dotation"
| Epers_DotationLDS -> "dotation (LDS)"
| Epers_Education -> "education"
| Epers_Election -> "election"
| Epers_Emigration -> "emigration"
| Epers_Excommunication -> "excommunication"
| Epers_FamilyLinkLDS -> "family link (LDS)"
| Epers_FirstCommunion -> "first communion"
| Epers_Funeral -> "funeral"
| Epers_Graduate -> "graduation"
| Epers_Hospitalisation -> "hospitalisation"
| Epers_Illness -> "illness"
| Epers_Immigration -> "immigration"
| Epers_ListePassenger -> "passenger liste"
| Epers_MilitaryDistinction -> "military distinction"
| Epers_MilitaryPromotion -> "military promotion"
| Epers_MilitaryService -> "military service"
| Epers_MobilisationMilitaire -> "military mobilisation"
| Epers_Naturalisation -> "naturalisation"
| Epers_Occupation -> "occupation"
| Epers_Ordination -> "ordination"
| Epers_Property -> "property"
| Epers_Recensement -> "recensement"
| Epers_Residence -> "residence"
| Epers_Retired -> "retirement"
| Epers_ScellentChildLDS -> "scellent child (LDS)"
| Epers_ScellentParentLDS -> "scellent parent (LDS)"
| Epers_ScellentSpouseLDS -> "scellent spouse (LDS)"
| Epers_VenteBien -> "sell"
| Epers_Will -> "will"
| Epers_Name n -> sou base n
let string_of_efam_name base efam_name =
match efam_name with
| Efam_Marriage -> "marriage"
| Efam_NoMarriage -> "relation"
| Efam_NoMention -> "relation"
| Efam_Engage -> "engagement"
| Efam_Divorce -> "divorce"
| Efam_Separated -> "separation"
| Efam_Annulation -> "annulation"
| Efam_MarriageBann -> "marriage bann"
| Efam_MarriageContract -> "marriage contract"
| Efam_MarriageLicense -> "marriage licence"
| Efam_PACS -> "PACS"
| Efam_Residence -> "residence"
| Efam_Name n -> sou base n
let print_base_error oc base = function
| AlreadyDefined p ->
Printf.fprintf oc "%s is defined several times\n" (designation base p)
| OwnAncestor p ->
Printf.fprintf oc "%s is his/her own ancestor\n" (designation base p)
| BadSexOfMarriedPerson p ->
Printf.fprintf oc "%s bad sex for a married person\n" (designation base p)
let print_base_warning oc base = function
| BigAgeBetweenSpouses (p1, p2, a) ->
Printf.fprintf oc
"The difference of age between %s and %s is quite important: %d\n"
(designation base p1) (designation base p2) a.year
| BirthAfterDeath p ->
Printf.fprintf oc "%s born after his/her death\n" (designation base p)
| ChangedOrderOfChildren (ifam, _, _, _) ->
let cpl = foi base ifam in
Printf.fprintf oc "Changed order of children of %s and %s\n"
(designation base (poi base (get_father cpl)))
(designation base (poi base (get_mother cpl)))
| ChildrenNotInOrder (ifam, _, elder, x) ->
let cpl = foi base ifam in
Printf.fprintf oc
"The following children of\n %s\nand\n %s\nare not in order:\n"
(designation base (poi base (get_father cpl)))
(designation base (poi base (get_mother cpl)));
Printf.fprintf oc "- %s\n" (designation base elder);
Printf.fprintf oc "- %s\n" (designation base x)
| ChangedOrderOfMarriages (p, _, _) ->
Printf.fprintf oc "Changed order of marriages of %s\n"
(designation base p)
| ChangedOrderOfFamilyEvents (ifam, _, _) ->
let cpl = foi base ifam in
Printf.fprintf oc "Changed order of family's events for %s\n"
(designation base (poi base (get_father cpl)));
Printf.fprintf oc "Changed order of family's events for %s\n"
(designation base (poi base (get_mother cpl)))
| ChangedOrderOfPersonEvents (p, _, _) ->
Printf.fprintf oc "Changed order of person's events for %s\n"
(designation base p)
| CloseChildren (ifam, c1, c2) ->
let cpl = foi base ifam in
Printf.fprintf oc
"The following children of\n %s\nand\n %s\nare born very close:\n"
(designation base (poi base (get_father cpl)))
(designation base (poi base (get_mother cpl)));
Printf.fprintf oc "- %s\n" (designation base c1);
Printf.fprintf oc "- %s\n" (designation base c2)
| DeadOld (p, a) ->
Printf.fprintf oc "%s died at the advanced age of %d years old\n"
(designation base p) a.year
| DeadTooEarlyToBeFather (father, child) ->
Printf.fprintf oc "%s " (designation base child);
Printf.fprintf oc
"is born more than 2 years after the death of his/her father";
Printf.fprintf oc " %s\n" (designation base father)
| DistantChildren (ifam, p1, p2) ->
let cpl = foi base ifam in
Printf.fprintf oc
"The following children of\n %s\nand\n %s\nare born very close:\n"
(designation base (poi base (get_father cpl)))
(designation base (poi base (get_mother cpl)));
Printf.fprintf oc "- %s\n" (designation base p1);
Printf.fprintf oc "- %s\n" (designation base p2)
| FEventOrder (p, e1, e2) ->
Printf.fprintf oc "%s's %s before his/her %s\n" (designation base p)
(string_of_efam_name base e1.efam_name)
(string_of_efam_name base e2.efam_name)
| FWitnessEventAfterDeath (p, e, _fam) ->
Printf.fprintf oc "%s " (designation base p);
Printf.fprintf oc "witnessed the %s after his/her death\n"
(string_of_efam_name base e.efam_name)
| FWitnessEventBeforeBirth (p, e, _fam) ->
Printf.fprintf oc "%s " (designation base p);
Printf.fprintf oc "witnessed the %s before his/her birth\n"
(string_of_efam_name base e.efam_name)
| IncoherentSex (p, fixed, not_fixed) ->
Printf.fprintf oc "%s sex not coherent with relations"
(designation base p);
if fixed > 0 then
if not_fixed > 0 then
Printf.fprintf oc " (fixed in %d of the %d cases)" fixed
(fixed + not_fixed)
else Printf.fprintf oc " (fixed)";
Printf.fprintf oc "\n"
| IncoherentAncestorDate (anc, p) ->
Printf.fprintf oc "%s " (designation base p);
Printf.fprintf oc " has a younger ancestor:";
Printf.fprintf oc " %s\n" (designation base anc)
| MarriageDateAfterDeath p ->
Printf.fprintf oc "%s " (designation base p);
Printf.fprintf oc "marriage after his/her death\n"
| MarriageDateBeforeBirth p ->
Printf.fprintf oc "%s " (designation base p);
Printf.fprintf oc "marriage before his/her birth\n"
| MotherDeadBeforeChildBirth (mother, child) ->
Printf.fprintf oc "%s is born after the death of his/her mother %s\n"
(designation base child) (designation base mother)
| ParentBornAfterChild (parent, child) ->
Printf.fprintf oc "%s born after his/her child %s\n"
(designation base parent) (designation base child)
| ParentTooOld (p, a, _) ->
Printf.fprintf oc "%s was parent at age of %d\n" (designation base p)
a.year
| ParentTooYoung (p, a, _) ->
Printf.fprintf oc "%s was parent at age of %d\n" (designation base p)
a.year
| PossibleDuplicateFam (f1, f2) ->
Printf.fprintf oc "possible duplicate families: %s and %s\n"
(string_of_ifam f1) (string_of_ifam f2)
| PossibleDuplicateFamHomonymous (f1, f2, 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
Printf.fprintf oc
"possible duplicate families: %s and %s, %s has unions with several \
persons named %s\n"
(string_of_ifam f1) (string_of_ifam f2)
(designation base (poi base curr))
(designation base (poi base hom))
| PEventOrder (p, e1, e2) ->
Printf.fprintf oc "%s's %s before his/her %s\n" (designation base p)
(string_of_epers_name base e1.epers_name)
(string_of_epers_name base e2.epers_name)
| PWitnessEventAfterDeath (p, e, _origin) ->
Printf.fprintf oc "%s " (designation base p);
Printf.fprintf oc "witnessed the %s after his/her death\n"
(string_of_epers_name base e.epers_name)
| PWitnessEventBeforeBirth (p, e, _origin) ->
Printf.fprintf oc "%s " (designation base p);
Printf.fprintf oc "witnessed the %s before his/her birth\n"
(string_of_epers_name base e.epers_name)
| TitleDatesError (p, t) ->
Printf.fprintf oc "%s " (designation base p);
Printf.fprintf oc "has incorrect title dates as:\n";
Printf.fprintf oc " %s %s\n" (sou base t.t_ident) (sou base t.t_place)
| UndefinedSex p ->
Printf.fprintf oc "Undefined sex for %s\n" (designation base p)
| YoungForMarriage (p, a, _) | OldForMarriage (p, a, _) ->
Printf.fprintf oc "%s married at age %d\n" (designation base p) a.year
type check_date =
| CheckBefore of int
| CheckAfter of int
| CheckOther of int
| CheckInfered of check_date
let min_year_of p =
let aux = function
| { prec = After; year } -> CheckAfter year
| { prec = Before; year } -> CheckBefore year
| { year } -> CheckOther year
in
Option.map aux (Date.cdate_to_dmy_opt (get_birth p))
let dummy_date = CheckInfered (CheckOther max_int)
(* check ad print warning if ancestors is born before person *)
let rec check_ancestors base warning year year_tab ip ini_p =
let infer = function
| CheckBefore i -> CheckInfered (CheckBefore (pred i))
| CheckAfter i -> CheckInfered (CheckAfter (pred i))
| CheckOther i -> CheckInfered (CheckOther (pred i))
| CheckInfered (CheckBefore i) -> CheckInfered (CheckBefore (pred i))
| CheckInfered (CheckAfter i) -> CheckInfered (CheckAfter (pred i))
| CheckInfered (CheckOther i) -> CheckInfered (CheckOther (pred i))
| _ -> assert false
in
let own = function CheckInfered _ -> false | _ -> true in
let test a b p p' =
match (a, b) with
| ( CheckAfter y,
( CheckBefore y'
| CheckOther y'
| CheckInfered (CheckBefore y')
| CheckInfered (CheckOther y') ) )
when y >= y' ->
warning (IncoherentAncestorDate (Lazy.force p, p'))
| _ -> ()
in
if Gwdb.Marker.get year_tab ip = dummy_date then (
let p = poi base ip in
let new_year, new_ini_p =
match min_year_of p with Some y -> (y, p) | None -> (infer year, ini_p)
in
Gwdb.Marker.set year_tab ip new_year;
test new_year year (lazy p) ini_p;
match get_parents p with
| Some ifam ->
let fam = foi base ifam in
let f ip =
let year = Gwdb.Marker.get year_tab ip in
if year = dummy_date then
check_ancestors base warning new_year year_tab ip new_ini_p
else if own year then
test year new_year (lazy (poi base ip)) new_ini_p
in
f @@ get_father fam;
f @@ get_mother fam
| None -> ())
let check_base ?(verbose = false) ?(mem = false) base error warning changed_p =
if not mem then (
Gwdb.load_persons_array base;
Gwdb.load_ascends_array base;
Gwdb.load_unions_array base;
Gwdb.load_couples_array base);
let persons = Gwdb.ipers base in
let len = Gwdb.Collection.length persons in
let year_tab = Gwdb.iper_marker (Gwdb.ipers base) dummy_date in
if verbose then (
Printf.eprintf "check persons\n";
ProgrBar.start ();
Gwdb.Collection.iteri
(fun i ip ->
ProgrBar.run i len;
let p = poi base ip in
if Gwdb.Marker.get year_tab ip = dummy_date then
check_ancestors base warning dummy_date year_tab ip p;
match CheckItem.person ~onchange:false base warning p with
| Some ippl -> List.iter changed_p ippl
| None -> ())
persons;
ProgrBar.finish ())
else
Gwdb.Collection.iter
(fun ip ->
let p = poi base ip in
if Gwdb.Marker.get year_tab ip = dummy_date then
check_ancestors base warning dummy_date year_tab ip p;
match CheckItem.person ~onchange:false base warning p with
| Some ippl -> List.iter changed_p ippl
| None -> ())
persons;
if not mem then (
Gwdb.clear_unions_array base;
Gwdb.load_families_array base;
Gwdb.load_descends_array base);
let families = Gwdb.ifams base in
let len = Gwdb.Collection.length families in
if verbose then (
Printf.eprintf "check families\n";
ProgrBar.start ();
Gwdb.Collection.iteri
(fun i ifam ->
ProgrBar.run i len;
CheckItem.family ~onchange:false base warning ifam @@ foi base ifam)
families;
ProgrBar.finish ())
else
Gwdb.Collection.iter
(fun ifam ->
CheckItem.family ~onchange:false base warning ifam @@ foi base ifam)
families;
if not mem then (
Gwdb.clear_persons_array base;
Gwdb.clear_families_array base;
Gwdb.clear_descends_array base);
Consang.check_noloop base error;
if not mem then (
Gwdb.clear_ascends_array base;
Gwdb.clear_couples_array base)

23
lib/check.mli Normal file
View File

@@ -0,0 +1,23 @@
(* Copyright (c) 2006-2007 INRIA *)
(* checking database ; independent from its implementation on disk *)
open Gwdb
val print_base_error : out_channel -> base -> CheckItem.base_error -> unit
(** Print database specification error on the giving channel *)
val print_base_warning : out_channel -> base -> CheckItem.base_warning -> unit
(** Print database specification warning on the giving channel *)
val check_base :
?verbose:bool ->
?mem:bool ->
base ->
(CheckItem.base_error -> unit) ->
(CheckItem.base_warning -> unit) ->
(iper * person * Def.sex option * relation list option -> unit) ->
unit
(** [check_base base onwarning onerror _] makes full database proprety check. Checks every person and family separetely
with corresponding function inside [CheckItem] module. Checks also person's graph in order to find cycles (if person
is own ancestor). *)

1101
lib/checkItem.ml Normal file
View File

File diff suppressed because it is too large Load Diff

74
lib/checkItem.mli Normal file
View File

@@ -0,0 +1,74 @@
(* $Id: checkItem.mli,v 1.12 2007-09-05 13:19:25 ddr Exp $ *)
(* Copyright (c) 2006-2007 INRIA *)
open Gwdb
type base_error = person Def.error
(** Database specification error *)
type base_warning =
(iper, person, ifam, family, title, pers_event, fam_event) Def.warning
(** Database specification warning *)
(* *)
type base_misc = (person, family, title) Def.misc
val check_siblings :
?onchange:bool ->
base ->
(base_warning -> unit) ->
ifam * family ->
(person -> unit) ->
unit
(** [check_siblings ?onchange base warning (ifam, fam) callback]
Checks birth date consistency between siblings.
Also calls [callback] with each child. *)
val person :
?onchange:bool ->
base ->
(base_warning -> unit) ->
person ->
(iper * person * Def.sex option * relation list option) list option
(** [person onchange base warn p] checks person's properties:
- personal events
- person's age
- person's titles dates
- etc.
If [onchange] is set then sort person's events
Calls [warn] on corresponding [base_warning] when find some inconsistencies. *)
val family :
?onchange:bool -> base -> (base_warning -> unit) -> ifam -> family -> unit
(** [family onchange base warn f] checks family properties like :
- familial events
- parents marraige
- children age gap and birth
- etc.
If [onchange] is set then sort family's events
Calls [warn] on corresponding [base_warning] when find some inconsistencies. *)
val on_person_update : base -> (base_warning -> unit) -> person -> unit
(** Unlike [person] who checks directly the properties of a person, checks the properties
of a person in relation to other people (his children, parents, spouses, witnesses, etc).
Calls [warn] on corresponding [base_warning] when find some inconsistencies.
*)
val sort_children : base -> iper array -> (iper array * iper array) option
(** Sort array of children by their birth date from oldest to youngest.
Returns old array and sorted version. *)
val check_other_fields : base -> (base_misc -> unit) -> ifam -> family -> unit
(** Cheks if family, father and mother have sources. Otherwise call [misc] on [base_misc] *)
val eq_warning : base -> base_warning -> base_warning -> bool
(** equality between base_warnings *)
val person_warnings : Config.config -> base -> person -> base_warning list
(** [person_warnings conf base p]
Shorthand for [CheckItem.person] and [CheckItem.on_person_update] on [p]
and [CheckItem.check_siblings] on they children
using [auth_warning] for filtering.
*)

192
lib/config.ml Normal file
View File

@@ -0,0 +1,192 @@
(* Copyright (c) 1998-2007 INRIA *)
open Def
open Gwdb
type auth_scheme_kind =
| NoAuth
| TokenAuth of token_auth_scheme
| HttpAuth of http_auth_scheme
and token_auth_scheme = { ts_user : string; ts_pass : string }
and http_auth_scheme =
| Basic of basic_auth_scheme
| Digest of digest_auth_scheme
and basic_auth_scheme = {
bs_realm : string;
bs_user : string;
bs_pass : string;
}
and digest_auth_scheme = {
ds_username : string;
ds_realm : string;
ds_nonce : string;
ds_meth : string;
ds_uri : string;
ds_qop : string;
ds_nc : string;
ds_cnonce : string;
ds_response : string;
}
type output_conf = {
status : Def.httpStatus -> unit;
header : string -> unit;
body : string -> unit;
flush : unit -> unit;
}
type env = (string * Adef.encoded_string) list
type config = {
from : string;
api_mode : bool;
manitou : bool;
supervisor : bool;
wizard : bool;
is_printed_by_template : bool;
debug : bool;
query_start : float;
friend : bool;
just_friend_wizard : bool;
user : string;
username : string;
userkey : string;
auth_scheme : auth_scheme_kind;
command : string;
indep_command : string;
highlight : string;
lang : string;
vowels : string list;
default_lang : string;
browser_lang : string;
default_sosa_ref : iper * Gwdb.person option;
multi_parents : bool;
authorized_wizards_notes : bool;
public_if_titles : bool;
public_if_no_date : bool;
mutable setup_link : bool;
access_by_key : bool;
private_years : int;
private_years_death : int;
private_years_marriage : int;
hide_names : bool;
use_restrict : bool;
no_image : bool;
no_note : bool;
bname : string;
nb_of_persons : int;
cgi_passwd : string;
env : env;
mutable senv : env;
mutable henv : env;
base_env : (string * string) list (* content of .gwf file *);
allowed_titles : string list Lazy.t;
denied_titles : string list Lazy.t;
request : string list;
lexicon : (string, string) Hashtbl.t;
mutable charset : string;
is_rtl : bool;
left : string;
right : string;
auth_file : string;
border : int;
mutable n_connect : (int * int * int * (string * float) list) option;
today : dmy;
today_wd : int;
time : int * int * int;
ctime : float; (* TODO verify usefulness *)
mutable output_conf : output_conf;
(* HTTP printer *)
(* prefix for image urls:
the value of argument -images_url if specified, otherwise
command ^ "?m=IM&v=" in CGI mode
"images" otherwise *)
gw_prefix : string;
images_prefix : string;
etc_prefix : string;
(* in CGI mode, provides location of etc files to Apache for direct loading *)
(* if true, the base name is in the b argument of the query string: ?b=BASE&...
if false, the base name is the last element of the uri path: .../base?... *)
cgi : bool;
forced_plugins : string list;
plugins : string list;
}
(**/**)
(** A dummy {!type:config} value, with uninitialized fields.
Used for testing purpose *)
let empty =
{
from = "";
manitou = false;
supervisor = false;
wizard = false;
api_mode = false;
is_printed_by_template = false;
debug = false;
query_start = 0.;
friend = false;
just_friend_wizard = false;
user = "";
username = "";
userkey = "";
auth_scheme = NoAuth;
command = "";
indep_command = "";
highlight = "";
lang = "";
vowels = [];
default_lang = "";
browser_lang = "";
default_sosa_ref = (Gwdb.dummy_iper, None);
multi_parents = false;
authorized_wizards_notes = false;
public_if_titles = false;
public_if_no_date = false;
setup_link = false;
access_by_key = false;
private_years = 0;
private_years_death = 0;
private_years_marriage = 0;
hide_names = false;
use_restrict = false;
no_image = false;
no_note = false;
bname = "";
nb_of_persons = -1;
cgi_passwd = "";
env = [];
senv = [];
henv = [];
base_env = [];
allowed_titles = lazy [];
denied_titles = lazy [];
request = [];
lexicon = Hashtbl.create 16;
charset = "";
is_rtl = false;
left = "";
right = "";
auth_file = "";
border = 0;
n_connect = None;
today = { Def.day = 0; month = 0; year = 0; delta = 0; prec = Def.Sure };
today_wd = 0;
time = (0, 0, 0);
ctime = 0.;
gw_prefix = "";
images_prefix = "";
etc_prefix = "";
cgi = false;
output_conf =
{ status = ignore; header = ignore; body = ignore; flush = ignore };
forced_plugins = [];
plugins = [];
}
(**/**)

127
lib/config.mli Normal file
View File

@@ -0,0 +1,127 @@
open Def
open Gwdb
(** Authentication scheme data type *)
type auth_scheme_kind =
| NoAuth
| TokenAuth of token_auth_scheme
| HttpAuth of http_auth_scheme
and token_auth_scheme = { ts_user : string; ts_pass : string }
(** Authentication via security token *)
(** Authentication via HTTP *)
and http_auth_scheme =
| Basic of basic_auth_scheme
| Digest of digest_auth_scheme
and basic_auth_scheme = {
bs_realm : string;
bs_user : string;
bs_pass : string;
}
(** Basic authentication scheme inside {i Autorization} HTTP header *)
and digest_auth_scheme = {
ds_username : string;
ds_realm : string;
ds_nonce : string;
ds_meth : string;
ds_uri : string;
ds_qop : string;
ds_nc : string;
ds_cnonce : string;
ds_response : string;
}
(** Digest authentication scheme inside {i Autorization} HTTP header *)
type output_conf = {
status : Def.httpStatus -> unit;
header : string -> unit;
body : string -> unit;
flush : unit -> unit;
}
(** HTTP printer, that prints and sends requests on the user's socket *)
type env = (string * Adef.encoded_string) list
(** Geneweb configuration data type *)
type config = {
from : string;
api_mode : bool;
manitou : bool;
supervisor : bool;
wizard : bool;
is_printed_by_template : bool;
debug : bool;
query_start : float;
friend : bool;
just_friend_wizard : bool;
user : string;
username : string;
userkey : string;
auth_scheme : auth_scheme_kind;
command : string;
indep_command : string;
highlight : string;
lang : string;
vowels : string list;
default_lang : string;
browser_lang : string;
default_sosa_ref : iper * Gwdb.person option;
multi_parents : bool;
authorized_wizards_notes : bool;
public_if_titles : bool;
public_if_no_date : bool;
mutable setup_link : bool;
access_by_key : bool;
private_years : int;
private_years_death : int;
private_years_marriage : int;
hide_names : bool;
use_restrict : bool;
no_image : bool;
no_note : bool;
bname : string;
nb_of_persons : int;
cgi_passwd : string;
env : env;
mutable senv : env;
mutable henv : env;
base_env : (string * string) list (* content of .gwf file *);
allowed_titles : string list Lazy.t;
denied_titles : string list Lazy.t;
request : string list;
lexicon : (string, string) Hashtbl.t;
mutable charset : string;
is_rtl : bool;
left : string;
right : string;
auth_file : string;
border : int;
mutable n_connect : (int * int * int * (string * float) list) option;
today : dmy;
today_wd : int;
time : int * int * int;
ctime : float;
mutable output_conf : output_conf;
(* HTTP printer *)
(* prefix for image urls:
the value of argument -images_url if specified, otherwise
command ^ "?m=IM&v=" in CGI mode
"images" otherwise *)
gw_prefix : string;
images_prefix : string;
(* if true, the base name is in the b argument of the query string: ?b=BASE&...
if false, the base name is the last element of the uri path: .../base?... *)
etc_prefix : string;
(* in CGI mode, provides location of etc files to Apache for direct loading *)
cgi : bool;
forced_plugins : string list;
plugins : string list;
}
(** Geneweb configuration data type *)
val empty : config
(** A dummy {!type:config} value, with uninitialized fields.
Used for testing purpose *)

290
lib/core/consang.ml Normal file
View File

@@ -0,0 +1,290 @@
(* Copyright (c) 1998-2007 INRIA *)
(* Algorithm relationship and links from Didier Remy *)
open Def
open Gwdb
type anc_stat = MaybeAnc | IsAnc
(* relationship:
- elim_ancestor
to prune displayed relationships
- anc_stat1, anc_stat2
optimization to answer faster when ancestors list is exhausted
- lens1, lens2:
the third parameter (list iper) of the list has been added to
be able to reconstitute the branch in case of the sex of the
persons in the branch is important to display the relationship
text
*)
type relationship = {
mutable weight1 : float;
mutable weight2 : float;
mutable relationship : float;
mutable lens1 : (int * int * iper list) list;
mutable lens2 : (int * int * iper list) list;
mutable inserted : int;
mutable elim_ancestors : bool;
mutable anc_stat1 : anc_stat;
mutable anc_stat2 : anc_stat;
}
type relationship_info = {
tstab : (Gwdb.iper, int) Gwdb.Marker.t;
reltab : (Gwdb.iper, relationship) Gwdb.Marker.t;
mutable queue : Gwdb.iper list array;
}
let half x = x *. 0.5
type visit =
| NotVisited (* not visited person *)
| BeingVisited
(* visited person but visit of ascendants haven't been terminated *)
| Visited (* visited person and his ascendants *)
let rec noloop_aux base error tab i =
match Gwdb.Marker.get tab i with
| NotVisited ->
(match get_parents (poi base i) with
| Some ifam ->
let fam = foi base ifam in
let fath = get_father fam in
let moth = get_mother fam in
Gwdb.Marker.set tab i BeingVisited;
noloop_aux base error tab fath;
noloop_aux base error tab moth
| None -> ());
Gwdb.Marker.set tab i Visited
| BeingVisited -> error (OwnAncestor (poi base i))
| Visited -> ()
(** It is highly recommended to load ascends and couples array before
running [check_noloop]
*)
let check_noloop base error =
let tab = Gwdb.iper_marker (Gwdb.ipers base) NotVisited in
Gwdb.Collection.iter (noloop_aux base error tab) (Gwdb.ipers base)
let check_noloop_for_person_list base error list =
let tab = Gwdb.iper_marker (Gwdb.ipers base) NotVisited in
List.iter (noloop_aux base error tab) list
exception TopologicalSortError of person
(* Return tab such as: i is an ancestor of j => tab.(i) > tab.(j) *)
(* This complicated topological sort has the important following properties:
- only "ascends" has to be loaded; no need to load "union" and "descend"
which use much memory space.
- the value of tab is minimum; it is important for the optimization of
relationship computation (stopping the computation when the ancestor
list of one of the person is exhausted).
*)
let topological_sort base poi =
let persons = Gwdb.ipers base in
let tab = Gwdb.iper_marker (Gwdb.ipers base) 0 in
let cnt = ref 0 in
Gwdb.Collection.iter
(fun i ->
let a = poi base i in
match get_parents a with
| Some ifam ->
let cpl = foi base ifam in
let ifath = get_father cpl in
let imoth = get_mother cpl in
Gwdb.Marker.set tab ifath (Gwdb.Marker.get tab ifath + 1);
Gwdb.Marker.set tab imoth (Gwdb.Marker.get tab imoth + 1)
| _ -> ())
persons;
(* starting from the leaf vertex of graph (persons without childs) *)
let todo =
Gwdb.Collection.fold
(fun acc i -> if Gwdb.Marker.get tab i = 0 then i :: acc else acc)
[] persons
in
let rec loop tval list =
if list = [] then ()
else
let new_list =
List.fold_left
(fun new_list i ->
let a = poi base i in
Gwdb.Marker.set tab i tval;
incr cnt;
match get_parents a with
| Some ifam ->
let cpl = foi base ifam in
let ifath = get_father cpl in
let imoth = get_mother cpl in
Gwdb.Marker.set tab ifath (Gwdb.Marker.get tab ifath - 1);
Gwdb.Marker.set tab imoth (Gwdb.Marker.get tab imoth - 1);
let new_list =
if Gwdb.Marker.get tab ifath = 0 then ifath :: new_list
else new_list
in
if Gwdb.Marker.get tab imoth = 0 then imoth :: new_list
else new_list
| _ -> new_list)
[] list
in
loop (tval + 1) new_list
in
loop 0 todo;
if !cnt <> nb_of_persons base then
check_noloop base (function
| OwnAncestor p -> raise (TopologicalSortError p)
| _ -> assert false);
tab
let phony_rel =
{
weight1 = 0.0;
weight2 = 0.0;
relationship = 0.0;
lens1 = [];
lens2 = [];
inserted = 0;
elim_ancestors = false;
anc_stat1 = MaybeAnc;
anc_stat2 = MaybeAnc;
}
let make_relationship_info base tstab =
let tab = Gwdb.iper_marker (Gwdb.ipers base) phony_rel in
{ tstab; reltab = tab; queue = [||] }
let rec insert_branch_len_rec ((len, n, ip) as x) = function
| [] -> [ (len, n, [ ip ]) ]
| ((len1, n1, ipl1) as y) :: lens ->
if len = len1 then
let n2 = n + n1 in
let n2 = if n < 0 || n1 < 0 || n2 < 0 then -1 else n2 in
(len1, n2, ip :: ipl1) :: lens
else y :: insert_branch_len_rec x lens
let insert_branch_len ip lens (len, n, _ipl) =
insert_branch_len_rec (succ len, n, ip) lens
let consang_of p =
if get_consang p = Adef.no_consang then 0.0
else Adef.float_of_fix (get_consang p)
let mark = ref 0
let new_mark () =
incr mark;
!mark
let relationship_and_links base ri b ip1 ip2 =
let i1 = ip1 in
let i2 = ip2 in
if i1 = i2 then (1.0, [])
else
let reltab = ri.reltab in
let tstab = ri.tstab in
let yes_inserted = new_mark () in
let reset u =
let tu = Gwdb.Marker.get reltab u in
if tu == phony_rel then
Gwdb.Marker.set reltab u
{
weight1 = 0.0;
weight2 = 0.0;
relationship = 0.0;
lens1 = [];
lens2 = [];
inserted = yes_inserted;
elim_ancestors = false;
anc_stat1 = MaybeAnc;
anc_stat2 = MaybeAnc;
}
else (
tu.weight1 <- 0.0;
tu.weight2 <- 0.0;
tu.relationship <- 0.0;
tu.lens1 <- [];
tu.lens2 <- [];
tu.inserted <- yes_inserted;
tu.elim_ancestors <- false;
tu.anc_stat1 <- MaybeAnc;
tu.anc_stat2 <- MaybeAnc)
in
let qi = ref (min (Gwdb.Marker.get tstab i1) (Gwdb.Marker.get tstab i2)) in
let qmax = ref (-1) in
let insert u =
let v = Gwdb.Marker.get tstab u in
reset u;
(if v >= Array.length ri.queue then
let len = Array.length ri.queue in
ri.queue <- Array.append ri.queue (Array.make (v + 1 - len) []));
if !qmax < 0 then (
for i = !qi to v - 1 do
ri.queue.(i) <- []
done;
qmax := v;
ri.queue.(v) <- [ u ])
else (
if v > !qmax then (
for i = !qmax + 1 to v do
ri.queue.(i) <- []
done;
qmax := v);
ri.queue.(v) <- u :: ri.queue.(v))
in
let relationship = ref 0.0 in
let nb_anc1 = ref 1 in
let nb_anc2 = ref 1 in
let tops = ref [] in
let treat_parent ip_from u y =
if (Gwdb.Marker.get reltab y).inserted <> yes_inserted then insert y;
let ty = Gwdb.Marker.get reltab y in
let p1 = half u.weight1 in
let p2 = half u.weight2 in
if u.anc_stat1 = IsAnc && ty.anc_stat1 <> IsAnc then (
ty.anc_stat1 <- IsAnc;
incr nb_anc1);
if u.anc_stat2 = IsAnc && ty.anc_stat2 <> IsAnc then (
ty.anc_stat2 <- IsAnc;
incr nb_anc2);
ty.weight1 <- ty.weight1 +. p1;
ty.weight2 <- ty.weight2 +. p2;
ty.relationship <- ty.relationship +. (p1 *. p2);
if u.elim_ancestors then ty.elim_ancestors <- true;
if b && not ty.elim_ancestors then (
ty.lens1 <- List.fold_left (insert_branch_len ip_from) ty.lens1 u.lens1;
ty.lens2 <- List.fold_left (insert_branch_len ip_from) ty.lens2 u.lens2)
in
let treat_ancestor u =
let tu = Gwdb.Marker.get reltab u in
let a = poi base u in
let contribution =
(tu.weight1 *. tu.weight2) -. (tu.relationship *. (1.0 +. consang_of a))
in
if tu.anc_stat1 = IsAnc then decr nb_anc1;
if tu.anc_stat2 = IsAnc then decr nb_anc2;
relationship := !relationship +. contribution;
if b && contribution <> 0.0 && not tu.elim_ancestors then (
tops := u :: !tops;
tu.elim_ancestors <- true);
match get_parents a with
| Some ifam ->
let cpl = foi base ifam in
treat_parent u tu (get_father cpl);
treat_parent u tu (get_mother cpl)
| _ -> ()
in
insert i1;
insert i2;
(Gwdb.Marker.get reltab i1).weight1 <- 1.0;
(Gwdb.Marker.get reltab i2).weight2 <- 1.0;
(Gwdb.Marker.get reltab i1).lens1 <- [ (0, 1, []) ];
(Gwdb.Marker.get reltab i2).lens2 <- [ (0, 1, []) ];
(Gwdb.Marker.get reltab i1).anc_stat1 <- IsAnc;
(Gwdb.Marker.get reltab i2).anc_stat2 <- IsAnc;
while !qi <= !qmax && !nb_anc1 > 0 && !nb_anc2 > 0 do
List.iter treat_ancestor ri.queue.(!qi);
incr qi
done;
(half !relationship, !tops)

64
lib/core/consang.mli Normal file
View File

@@ -0,0 +1,64 @@
(* Copyright (c) 1998-2007 INRIA *)
open Def
open Gwdb
(* TODOOCP: doc *)
type anc_stat
(** Relation with ancestor status *)
type relationship = {
mutable weight1 : float;
mutable weight2 : float;
mutable relationship : float;
mutable lens1 : (int * int * iper list) list;
mutable lens2 : (int * int * iper list) list;
mutable inserted : int;
mutable elim_ancestors : bool;
mutable anc_stat1 : anc_stat;
mutable anc_stat2 : anc_stat;
}
(** Consanguinity information attached to person (relationship between parents) *)
type relationship_info = {
(* Information about topological rank for each person *)
tstab : (Gwdb.iper, int) Gwdb.Marker.t;
reltab : (Gwdb.iper, relationship) Gwdb.Marker.t;
mutable queue : Gwdb.iper list array;
}
(** Computation consanguinity state for every person in the base *)
exception TopologicalSortError of person
(** Error that could occure while topological sorting, and raised when person is ancestor of himself. *)
val topological_sort :
Gwdb.base ->
(Gwdb.base -> Gwdb.iper -> Gwdb.person) ->
(Gwdb.iper, int) Gwdb.Marker.t
(** Returns result of topological sort of persons. Result is represented as marker that associates to every person in the base his
topologic rank (let's suppose [r]). Global rule is : if person p1 is ancestor of p2 then r(p1) > r(p2). For example, all leaf
persons (without children) have rank 0, their parents (if no another child that has child themself) - rank 1, parents of their
parents - rank 2, etc. Raises [TopologicalSortError] if person is directly or undirectly is ancestor of himself (cycle). *)
val make_relationship_info :
base -> (Gwdb.iper, int) Gwdb.Marker.t -> relationship_info
(** Initialise relationship info. *)
(* Returns relationship rate between two person and common ancestors (is exists). *)
val relationship_and_links :
base ->
relationship_info ->
bool ->
Gwdb.iper ->
Gwdb.iper ->
float * Gwdb.iper list
val check_noloop : base -> (person error -> unit) -> unit
(** [check_noloop base onerror] scans database person's oriented graph (vertex is a person and edge is parenthood from child to parent). If
cycle is found (person is directly or undirectly is ancestor of himself) calls [onerror] with [OwnAncestor] error. Array of
ascendants should be load in the memory. *)
val check_noloop_for_person_list :
base -> (person error -> unit) -> Gwdb.iper list -> unit
(** Same as [check_noloop] but scans only specified list of persons and their ancestors instead of entire database. *)

142
lib/core/consangAll.ml Normal file
View File

@@ -0,0 +1,142 @@
(* Copyright (c) 1998-2007 INRIA *)
open Gwdb
(* let rec clear_descend_consang base consang mark ifam =
* let des = foi base ifam in
* Array.iter
* (fun ip ->
* if not (Gwdb.Marker.get mark ip) then
* begin
* consang ip Adef.no_consang;
* Gwdb.Marker.set mark ip true ;
* let u = poi base ip in
* Array.iter (clear_descend_consang base consang mark) (get_family u)
* end)
* (get_children des) *)
let relationship base tab ip1 ip2 =
fst (Consang.relationship_and_links base tab false ip1 ip2)
let trace verbosity cnt max_cnt =
if verbosity >= 2 then (
Printf.eprintf "%7d\008\008\008\008\008\008\008" cnt;
flush stderr)
else if verbosity >= 1 then ProgrBar.run (max_cnt - cnt) max_cnt
let consang_array base =
let patched = ref false in
let fget i = get_parents @@ poi base i in
let cget i = get_consang @@ poi base i in
let cset i v =
patched := true;
patch_ascend base i
Def.{ (gen_ascend_of_person @@ poi base i) with consang = v }
in
(fget, cget, cset, patched)
let compute ?(verbosity = 2) base from_scratch =
let () = load_ascends_array base in
let () = load_couples_array base in
let fget, cget, cset, patched = consang_array base in
(try
let tab =
let ts = Consang.topological_sort base poi in
Consang.make_relationship_info base ts
in
let persons = Gwdb.ipers base in
let families = Gwdb.ifams base in
let consang_tab = Gwdb.ifam_marker families Adef.no_consang in
let cnt = ref 0 in
(* FIXME *)
(* if not from_scratch then
* begin
* let mark = Gwdb.Marker.make (Gwdb.Collection.length persons) false in
* List.iter
* (fun ip ->
* let u = poi base ip in
* Array.iter (clear_descend_consang base cset mark) (get_family u))
* (patched_ascends base)
* end; *)
Gwdb.Collection.iter
(fun i ->
if from_scratch then (
cset i Adef.no_consang;
incr cnt)
else
let cg = cget i in
Option.iter
(fun ifam -> Gwdb.Marker.set consang_tab ifam cg)
(fget i);
if cg = Adef.no_consang then incr cnt)
persons;
(* number of persons which need consanguinity to be computed *)
let max_cnt = !cnt in
let most = ref None in
if verbosity >= 1 then Printf.eprintf "To do: %d persons\n" max_cnt;
if max_cnt <> 0 then
if verbosity >= 2 then (
Printf.eprintf "Computing consanguinity...";
flush stderr)
else if verbosity >= 1 then ProgrBar.start ();
let running = ref true in
while !running do
running := false;
Gwdb.Collection.iter
(fun i ->
(* if person's consanguinity wasn't calculated *)
if cget i = Adef.no_consang then
match fget i with
(* if person has parents *)
| Some ifam ->
let pconsang = Gwdb.Marker.get consang_tab ifam in
(* if parent's family's consanguinity wasn't calculated *)
if pconsang = Adef.no_consang then
let cpl = foi base ifam in
let ifath = get_father cpl in
let imoth = get_mother cpl in
(* if parent's consanguinity was calculated *)
if
cget ifath != Adef.no_consang
&& cget imoth != Adef.no_consang
then (
let consang = relationship base tab ifath imoth in
trace verbosity !cnt max_cnt;
decr cnt;
let cg = Adef.fix_of_float consang in
cset i cg;
Gwdb.Marker.set consang_tab ifam cg;
if verbosity >= 2 then
if
match !most with Some m -> cg > cget m | None -> true
then (
Printf.eprintf "\nMax consanguinity %g for %s... "
consang
(Gutil.designation base (poi base i));
flush stderr;
most := Some i)
(* if it wasn't makes further another run over persons *))
else running := true
(* if it was then set to person his family's consanguinity *)
else (
trace verbosity !cnt max_cnt;
decr cnt;
cset i pconsang)
(* if he doesn't then set his consanguinity to 0 *)
| None ->
trace verbosity !cnt max_cnt;
decr cnt;
cset i (Adef.fix_of_float 0.0))
persons
done;
if max_cnt <> 0 then
if verbosity >= 2 then (
Printf.eprintf " done \n";
flush stderr)
else if verbosity >= 1 then ProgrBar.finish ()
with Sys.Break when verbosity > 0 ->
Printf.eprintf "\n";
flush stderr;
());
if !patched then Gwdb.commit_patches base;
!patched

11
lib/core/consangAll.mli Normal file
View File

@@ -0,0 +1,11 @@
(* Copyright (c) 2006-2007 INRIA *)
open Gwdb
val compute : ?verbosity:int -> base -> bool -> bool
(** [compute base from_scratch]
[?verbosity] may be 0, 1 or 2 (default is 2)
Compute consanguinity for each person in the base. If [from_scratch] is set then recompute
consanguinity for entire database.
Return [true] if base has been patched, [false] otherwise.
*)

12
lib/core/dune.in Normal file
View File

@@ -0,0 +1,12 @@
(library
(name geneweb_core)
(public_name geneweb.core)
(wrapped false)
(synopsis "GeneWeb Core library")
(preprocess (action (run %{bin:cppo} %%%CPPO_D%%% -V OCAML:%{ocaml_version} %{input-file})))
(libraries unix
geneweb_def
geneweb_gwdb
geneweb_sosa_mli
geneweb_util)
)

554
lib/cousins.ml Normal file
View File

@@ -0,0 +1,554 @@
(* Copyright (c) 1998-2007 INRIA *)
open Def
open Gwdb
open Util
type one_cousin =
Gwdb_driver.iper * Gwdb_driver.ifam list * Gwdb_driver.iper * int
type cousins_i_j = one_cousin list
let default_max_cnt = 2000
let max_cousin_level conf =
let default_max_cousin_lvl = 6 in
try int_of_string (List.assoc "max_cousins_level" conf.Config.base_env)
with Not_found | Failure _ -> default_max_cousin_lvl
let children_of base u =
Array.fold_right
(fun ifam list ->
let des = foi base ifam in
Array.fold_right List.cons (get_children des) list)
(get_family u) []
let children_of_fam base ifam = Array.to_list (get_children @@ foi base ifam)
let siblings_by conf base iparent ip =
let list = children_of base (pget conf base iparent) in
List.filter (( <> ) ip) list
let merge_siblings l1 l2 =
let l =
let rec rev_merge r = function
| [] -> r
| ((v, _) as x) :: l ->
rev_merge (if List.mem_assoc v r then r else x :: r) l
in
rev_merge (List.rev l1) l2
in
List.rev l
let siblings conf base ip =
match get_parents (pget conf base ip) with
| None -> []
| Some ifam ->
let cpl = foi base ifam in
let fath_sib =
List.map
(fun ip -> (ip, (get_father cpl, Male)))
(siblings_by conf base (get_father cpl) ip)
in
let moth_sib =
List.map
(fun ip -> (ip, (get_mother cpl, Female)))
(siblings_by conf base (get_mother cpl) ip)
in
merge_siblings fath_sib moth_sib
let rec has_desc_lev conf base lev u =
if lev <= 1 then true
else
Array.exists
(fun ifam ->
let des = foi base ifam in
Array.exists
(fun ip -> has_desc_lev conf base (lev - 1) (pget conf base ip))
(get_children des))
(get_family u)
let br_inter_is_empty b1 b2 =
List.for_all (fun (ip, _) -> not (List.mem_assoc ip b2)) b1
(* Algorithms *)
let sibling_has_desc_lev conf base lev (ip, _) =
has_desc_lev conf base lev (pget conf base ip)
(* begin cousins *)
let cousins_table = Array.make_matrix 1 1 []
let tm = Unix.localtime (Unix.time ())
let today_year = tm.Unix.tm_year + 1900
let cousins_t = ref None
let cousins_dates_t = ref None
let mal = 12
let mdl = 12
let update_min_max (min, max) date =
((if date < min then date else min), if date > max then date else max)
let max_ancestor_level conf base ip max_lvl =
let max_lvl =
match List.assoc_opt "max_anc_level" conf.Config.base_env with
| Some v when v <> "" -> int_of_string v
| _ -> max_lvl
in
let x = ref 0 in
let mark = Gwdb.iper_marker (Gwdb.ipers base) false in
(* Loading ITL cache, up to 10 generations. *)
let () = !GWPARAM_ITL.init_cache conf base ip 10 0 0 in
let rec loop level ip =
(* Ne traite pas l'index s'il a déjà été traité. *)
(* Pose surement probleme pour des implexes. *)
if not @@ Gwdb.Marker.get mark ip then (
(* Met à jour le tableau d'index pour indiquer que l'index est traité. *)
Gwdb.Marker.set mark ip true;
x := max !x level;
if !x <> max_lvl then
match get_parents (pget conf base ip) with
| Some ifam ->
let cpl = foi base ifam in
loop (succ level) (get_father cpl);
loop (succ level) (get_mother cpl)
| _ ->
x :=
max !x
(!GWPARAM_ITL.max_ancestor_level
conf base ip conf.bname max_lvl level))
in
loop 0 ip;
!x
let max_descendant_level conf _base _ip max_lvl =
(* TODO we should compute this value *)
match List.assoc_opt "max_desc_level" conf.Config.base_env with
| Some v when v <> "" -> int_of_string v
| _ -> max_lvl
let get_min_max_dates base l =
let rec loop (min, max) = function
| [] -> (min, max)
| one_cousin :: l -> (
let ip, _, _, _ = one_cousin in
let not_dead = get_death (poi base ip) = NotDead in
let birth_date, death_date, _ =
Gutil.get_birth_death_date (poi base ip)
in
match (birth_date, death_date) with
| Some (Dgreg (b, _)), Some (Dgreg (d, _)) ->
let birth =
match b.prec with
| After | Before | About | Maybe | OrYear _ | YearInt _ -> false
| _ -> true
in
let death =
match d.prec with
| After | Before | About | Maybe | OrYear _ | YearInt _ -> false
| _ -> true
in
if birth && death then
let min, max = update_min_max (min, max) b.year in
let min, max = update_min_max (min, max) d.year in
loop (min, max) l
else if birth && not death then
loop (update_min_max (min, max) b.year) l
else if (not birth) && death then
loop (update_min_max (min, max) d.year) l
else loop (min, max) l
| Some (Dgreg (b, _)), _ -> (
match b.prec with
| After | Before | About | Maybe | OrYear _ | YearInt _ ->
if not_dead then loop (update_min_max (min, max) today_year) l
else loop (min, max) l
| _ ->
let min, max = update_min_max (min, max) b.year in
if not_dead then loop (update_min_max (min, max) today_year) l
else loop (min, max) l)
| _, Some (Dgreg (d, _)) -> (
match d.prec with
| After | Before | About | Maybe | OrYear _ | YearInt _ ->
loop (min, max) l
| _ -> loop (update_min_max (min, max) d.year) l)
| _, _ -> loop (min, max) l)
in
loop (10000, -10000) l
let rec ascendants base acc l =
match l with
| [] -> acc
(* TODO type for this tuple?; why list of level? *)
| (ip, _, _, lev) :: l -> (
match get_parents (poi base ip) with
| None -> ascendants base acc l
| Some ifam ->
let cpl = foi base ifam in
let ifath = get_father cpl in
let imoth = get_mother cpl in
let acc = [ (ifath, [], ifath, lev + 1) ] @ acc in
let acc = [ (imoth, [], imoth, lev + 1) ] @ acc in
ascendants base acc l)
(* descendants des ip de liste1 sauf ceux présents dans liste2 *)
let descendants_aux base liste1 liste2 =
let liste2 =
List.map
(fun one_cousin ->
let ip, _, _, _ = one_cousin in
ip)
liste2
in
let rec loop0 acc = function
| [] -> acc
| one_cousin :: l ->
let ip, ifaml, ipar0, lev = one_cousin in
let fams = Array.to_list (get_family (poi base ip)) in
let chlds =
(* accumuler tous les enfants de ip *)
let rec loop1 acc fams =
(* iterer sur chaque famille *)
match fams with
| [] -> acc
| ifam :: fams ->
let children =
let rec loop2 acc2 children =
match children with
| [] -> acc2
| ipch :: children ->
loop2
((ipch, ifam :: ifaml, ipar0, lev - 1) :: acc2)
children
in
loop2 [] (Array.to_list (get_children (foi base ifam)))
in
loop1 (acc @ children) fams
in
loop1 [] fams
in
let chlds =
List.fold_left (* on élimine les enfants présents dans l2 *)
(fun acc one_cousin ->
let ip, _ifaml, _ipar, _lev = one_cousin in
if List.mem ip liste2 then acc else one_cousin :: acc)
[] chlds
in
loop0 (chlds @ acc) l
in
loop0 [] liste1
let descendants base cousins_cnt i j =
let liste1 = cousins_cnt.(i).(j - 1) in
let liste2 = if i > 0 then cousins_cnt.(i - 1).(j - 1) else [] in
descendants_aux base liste1 liste2
let init_cousins_cnt conf base p =
let _max_a_l = max_ancestor_level conf base (get_iper p) mal in
let max_a_l =
match p_getenv conf.Config.env "v" with
| Some v -> int_of_string v
| None -> 3
in
let max_d_l = max_descendant_level conf base (get_iper p) mdl in
let rec loop0 j cousins_cnt cousins_dates =
(* initiate lists of direct descendants *)
cousins_cnt.(0).(j) <- descendants base cousins_cnt 0 j;
cousins_dates.(0).(j) <- get_min_max_dates base cousins_cnt.(0).(j);
if j < Array.length cousins_cnt.(0) - 1 && cousins_cnt.(0).(j) <> [] then
loop0 (j + 1) cousins_cnt cousins_dates
else ()
in
let rec loop1 i cousins_cnt cousins_dates =
(* get ascendants *)
cousins_cnt.(i).(0) <- ascendants base [] cousins_cnt.(i - 1).(0);
cousins_dates.(i).(0) <- get_min_max_dates base cousins_cnt.(i).(0);
let rec loop2 i j cousins_cnt cousins_dates =
(* get descendants of c1, except persons of previous level (c2) *)
cousins_cnt.(i).(j) <- descendants base cousins_cnt i j;
cousins_dates.(i).(j) <- get_min_max_dates base cousins_cnt.(i).(j);
if j < Array.length cousins_cnt.(0) - 1 && cousins_cnt.(i).(j) <> [] then
loop2 i (j + 1) cousins_cnt cousins_dates
else if
(* TODO limit construction to l1 *)
i < Array.length cousins_cnt - 1 && cousins_cnt.(i).(0) <> []
then loop1 (i + 1) cousins_cnt cousins_dates
else ()
in
loop2 i 1 cousins_cnt cousins_dates
in
let expand_tables key v1 max_a_l cousins_cnt cousins_dates =
Printf.sprintf "******** Expand tables from %d to %d ********\n" v1 max_a_l
|> !GWPARAM.syslog `LOG_WARNING;
if
max_a_l + 3 > Sys.max_array_length
|| max_d_l + max_a_l + 3 > Sys.max_array_length
then failwith "Cousins table too large for system";
let new_cousins_cnt =
Array.make_matrix (max_a_l + 3) (max_d_l + max_a_l + 3) []
in
let new_cousins_dates =
Array.make_matrix (max_a_l + 3) (max_d_l + max_a_l + 3) (0, 0)
in
for i = 0 to v1 do
new_cousins_cnt.(i) <- cousins_cnt.(i);
new_cousins_dates.(i) <- cousins_dates.(i)
done;
loop0 (max_d_l + v1) cousins_cnt cousins_dates;
loop1 v1 cousins_cnt cousins_dates;
(key, max_a_l, cousins_cnt, cousins_dates)
in
let build_tables key =
Printf.sprintf "******** Compute %d × %d table ********\n" (max_a_l + 3)
(max_d_l + max_a_l + 3)
|> !GWPARAM.syslog `LOG_WARNING;
if
max_a_l + 3 > Sys.max_array_length
|| max_d_l + max_a_l + 3 > Sys.max_array_length
then failwith "Cousins table too large for system";
let () = load_ascends_array base in
let () = load_couples_array base in
(* +3: there may be more descendants for cousins than my own *)
let cousins_cnt =
Array.make_matrix (max_a_l + 3) (max_d_l + max_a_l + 3) []
in
let cousins_dates =
Array.make_matrix (max_a_l + 3) (max_d_l + max_a_l + 3) (0, 0)
in
cousins_cnt.(0).(0) <-
[ (get_iper p, [ Gwdb.dummy_ifam ], Gwdb.dummy_iper, 0) ];
cousins_dates.(0).(0) <- get_min_max_dates base cousins_cnt.(0).(0);
loop0 1 cousins_cnt cousins_dates;
loop1 1 cousins_cnt cousins_dates;
(key, max_a_l, cousins_cnt, cousins_dates)
in
let fn = Name.strip_lower @@ sou base @@ get_surname p in
let sn = Name.strip_lower @@ sou base @@ get_first_name p in
let occ = get_occ p in
let key = Format.sprintf "%s.%d.%s" fn occ sn in
match (!cousins_t, !cousins_dates_t) with
| Some t, Some d_t -> (t, d_t)
| _, _ ->
let _pnoc, _v1, t', d_t' =
match List.assoc_opt "cache_cousins_tool" conf.Config.base_env with
| Some "yes" -> (
Printf.eprintf "Cache_cousins_tool=yes\n";
flush stderr;
let pnoc, v1, t', d_t' =
Mutil.read_or_create_value "cousins_cache" (fun () ->
build_tables key)
in
match (pnoc, v1) with
| pnoc, v1 when pnoc = key && max_a_l <= v1 -> (pnoc, v1, t', d_t')
| pnoc, v1 when pnoc = key ->
let _pnoc, _v1, t', d_t' =
Mutil.read_or_create_value "cousins_cache" (fun () ->
build_tables key)
in
Sys.remove "cousins_cache";
Mutil.read_or_create_value "cousins_cache" ~magic:key (fun () ->
expand_tables key v1 max_a_l t' d_t')
| _ ->
Sys.remove "cousins_cache";
Mutil.read_or_create_value "cousins_cache" (fun () ->
build_tables key))
| _ ->
Printf.eprintf "Cache_cousins_tools=no\n";
flush stderr;
build_tables key
in
cousins_t := Some t';
cousins_dates_t := Some d_t';
flush stderr;
(t', d_t')
(* for cousins_dates.(l1).(l2) determine min or max date *)
let min_max_date conf base p min_max l1 l2 =
let _cousins_cnt, cousins_dates =
match (!cousins_t, !cousins_dates_t) with
| Some t, Some d_t -> (t, d_t)
| _, _ -> init_cousins_cnt conf base p
in
let i = try int_of_string l1 with Failure _ -> -1 in
let j = try int_of_string l2 with Failure _ -> -1 in
match (i, j) with
| -1, _ | _, -1 -> None
| _, _ ->
let min, max =
if
i + 1 > Array.length cousins_dates
|| j + 1 > Array.length cousins_dates.(i)
then (-1, -1)
else cousins_dates.(i).(j)
in
if min_max then Some min else Some max
(* determine non empty max ancestor level (max_i)
and non empty max descendant level
*)
let max_l1_l2 conf base p =
let cousins_cnt, _cousins_dates =
match (!cousins_t, !cousins_dates_t) with
| Some t, Some d_t -> (t, d_t)
| _, _ -> init_cousins_cnt conf base p
in
let max_i = Array.length cousins_cnt - 1 in
let max_j = Array.length cousins_cnt.(0) - 1 in
let max_a =
let rec loop0 i =
if cousins_cnt.(i).(0) <> [] && i < max_i - 1 then loop0 (i + 1) else i
in
loop0 0
in
let rec loop i j =
if cousins_cnt.(i).(j) <> [] then
if j < max_j then loop i (j + 1) else (max_a, j - i)
else if i < max_i && j < max_j then loop (i + 1) (j + 1)
else (max_a, j - i)
in
loop 0 0
let cousins_l1_l2_aux conf base l1 l2 p =
let il1 = int_of_string l1 in
let il2 = int_of_string l2 in
let cousins_cnt, _cousins_dates =
match (!cousins_t, !cousins_dates_t) with
| Some t, Some d_t -> (t, d_t)
| _, _ -> init_cousins_cnt conf base p
in
if il1 < Array.length cousins_cnt && il2 - il1 < Array.length cousins_cnt.(0)
then Some cousins_cnt.(il1).(il2)
else None
(* create a new list of (ip, (ifamll, iancl, cnt), lev) from one_cousin list *)
let cousins_fold l =
let _same_ifaml ifl1 ifl2 =
List.for_all2 (fun if1 if2 -> if1 = if2) ifl1 ifl2
in
let l = List.sort compare l in
let rec loop first acc (ip0, (ifaml0, iancl0, cnt0), lev0) = function
| one_cousin :: l ->
let ip, ifaml, ianc, lev = one_cousin in
if ip = ip0 then
loop false acc
( ip,
( ifaml :: ifaml0,
(if List.mem ianc iancl0 then iancl0 else ianc :: iancl0),
cnt0 + 1 ),
lev :: lev0 )
l
else
loop false
(if first || cnt0 = 0 then acc
else (ip0, (ifaml0, iancl0, cnt0), lev0) :: acc)
(ip, ([ ifaml ], [ ianc ], 1), [ lev ])
l
| [] ->
if first || cnt0 = 0 then acc
else (ip0, (ifaml0, iancl0, cnt0), lev0) :: acc
in
loop false [] (Gwdb.dummy_iper, ([], [], 0), [ 0 ]) l
let cousins_implex_cnt conf base l1 l2 p =
(* warning, this is expensive: two nested loops *)
let il1 = int_of_string l1 in
let il2 = int_of_string l2 in
let cousins_cnt, _cousins_dates =
match (!cousins_t, !cousins_dates_t) with
| Some t, Some d_t -> (t, d_t)
| _, _ -> init_cousins_cnt conf base p
in
let cousl0 = cousins_fold cousins_cnt.(il1).(il2) in
let rec loop0 cousl cnt =
match cousl with
| [] -> cnt
| (ip, _, _) :: cousl ->
loop0 cousl
(let rec loop1 cnt j =
if j = 0 then cnt
else
loop1
(let cousl_j = cousins_cnt.(il1).(j) in
let rec loop2 cousl_j cnt =
match cousl_j with
| [] -> cnt
| one_cousin :: cousl_j ->
let ipj, _, _, _ = one_cousin in
if ip = ipj then loop2 cousl_j (cnt + 1)
else loop2 cousl_j cnt
in
loop2 cousl_j cnt)
(j - 1)
in
loop1 cnt (il2 - 1))
in
loop0 cousl0 0
let asc_cnt_t = ref None
let desc_cnt_t = ref None
(* tableau des ascendants de p *)
let init_asc_cnt conf base p =
let max_a_l = max_ancestor_level conf base (get_iper p) mal in
match !asc_cnt_t with
| Some t -> t
| None ->
let t' =
let asc_cnt = Array.make (max_a_l + 2) [] in
asc_cnt.(0) <- [ (get_iper p, [ Gwdb.dummy_ifam ], Gwdb.dummy_iper, 0) ];
for i = 1 to max_a_l do
asc_cnt.(i) <- ascendants base [] asc_cnt.(i - 1)
done;
asc_cnt
in
asc_cnt_t := Some t';
t'
(* tableau des ascendants de p *)
let init_desc_cnt conf base p =
let max_d_l = max_descendant_level conf base (get_iper p) mdl in
match !desc_cnt_t with
| Some t -> t
| None ->
let t' =
let desc_cnt = Array.make (max_d_l + 2) [] in
desc_cnt.(0) <-
[ (get_iper p, [ Gwdb.dummy_ifam ], Gwdb.dummy_iper, 0) ];
for i = 1 to min max_d_l (Array.length desc_cnt - 1) do
desc_cnt.(i) <- descendants_aux base desc_cnt.(i - 1) []
done;
desc_cnt
in
desc_cnt_t := Some t';
t'
let anc_cnt_aux conf base lev at_to p =
let asc_cnt =
match !asc_cnt_t with Some t -> t | None -> init_asc_cnt conf base p
in
if at_to then if lev < Array.length asc_cnt then Some asc_cnt.(lev) else None
else
let rec loop acc i =
if i > lev || i >= Array.length asc_cnt - 1 then Some acc
else loop (asc_cnt.(i) @ acc) (i + 1)
in
loop [] 1
let desc_cnt_aux conf base lev at_to p =
let desc_cnt =
match !desc_cnt_t with Some t -> t | None -> init_desc_cnt conf base p
in
if at_to then
if lev < Array.length desc_cnt then Some desc_cnt.(lev) else None
else
let rec loop acc i =
if i > lev || i > Array.length desc_cnt - 1 then Some acc
else loop (desc_cnt.(i) @ acc) (i + 1)
in
loop [] 0
(* end cousins *)

134
lib/cousins.mli Normal file
View File

@@ -0,0 +1,134 @@
open Gwdb
open Config
type one_cousin =
Gwdb_driver.iper * Gwdb_driver.ifam list * Gwdb_driver.iper * int
type cousins_i_j = one_cousin list
val cousins_table : cousins_i_j array array
val cousins_dates_t : (int * int) array array option ref
val default_max_cnt : int
(** Default number of relatives that could be listed at the same page *)
val mal : int
(** max value of max_ancestor_level *)
val mdl : int
(** max value of max_descendant_level *)
val max_cousin_level : config -> int
val max_ancestor_level : config -> base -> iper -> int -> int
val max_descendant_level : config -> base -> iper -> int -> int
val children_of_fam : base -> ifam -> iper list
(** Retruns list of children of the giving family *)
val siblings : config -> base -> iper -> (iper * (iper * Def.sex)) list
(** Returns list of person's siblings that includes also half-blood siblings. Every sibling
is annotated with parent's id and parent's sex. For common father's and mother's
children father's annotation is preserved. *)
val has_desc_lev : config -> base -> int -> person -> bool
(** [has_desc_lev conf base lev p] tells if person [p] has descendants at the level [lev].
[lev] 2 represents his children, 3 represents grandchildren, etc. *)
val br_inter_is_empty : ('a * 'b) list -> ('a * 'c) list -> bool
(** Tells if two family branches don't itersect *)
val sibling_has_desc_lev : config -> base -> int -> iper * 'a -> bool
(** Same as [has_desc_lev] but used for a person's sibling as returned by [siblings]. *)
(* Functions to obtain info about cousins of a person *)
(* The various functions are typically called with two parameters:
- l1 : number of generations up
- l2 : number of generations down
0, 0 is myself
1, 1 is my brothers ans sisters
2, 1 is my uncle and aunts
2, 2 is my cousins
etc
*)
val init_cousins_cnt :
config ->
base ->
person ->
(Gwdb_driver.iper * Gwdb_driver.ifam list * Gwdb_driver.iper * int) list array
array
* (int * int) array array
(** initialise
- a 2D array of lists of cousins at l1, l2
for each cousin, record
- his family,
- his parent (through which he is reached),
- the level (possibly multiple levels dut to implex)
- a 2D array of tuples (min, max) for dates of cousins at l1, l2
*)
val min_max_date :
config -> base -> person -> bool -> string -> string -> int option
(** for cousins_dates.(l1).(l2) determine min or max date *)
val max_l1_l2 : config -> base -> person -> int * int
(** determine non empty max ancestor level (l1)
and non empty max descendant level *)
val cousins_l1_l2_aux :
config ->
base ->
string ->
(* up l1 generations *)
string ->
(* down l2 generations *)
person ->
(Gwdb_driver.iper * Gwdb_driver.ifam list * Gwdb_driver.iper * int) list
option
val cousins_implex_cnt :
config ->
base ->
string ->
(* up l1 generations *)
string ->
(* down l2 generations *)
person ->
int
(** for a list of "cousins" at level l1 l2,
cousins_implex computes cousins already seen at levels l < l2. *)
val cousins_fold :
(Gwdb_driver.iper * Gwdb_driver.ifam list * Gwdb_driver.iper * int) list ->
(Gwdb_driver.iper
* (Gwdb_driver.ifam list list * Gwdb_driver.iper list * int)
* int list)
list
(** create a new list of (ip, (ifamll, iancl, cnt), lev) from list of (ip, ifaml, ianc, lev)
The effect is to assemble multiple items under a single ip
*)
val anc_cnt_aux :
config ->
base ->
int ->
(* level *)
bool ->
(* up to ot at *)
person ->
(Gwdb_driver.iper * Gwdb_driver.ifam list * Gwdb_driver.iper * int) list
option
(** Get the list of ancestors up to or at level *)
val desc_cnt_aux :
config ->
base ->
int ->
(* level *)
bool ->
(* up to ot at *)
person ->
(Gwdb_driver.iper * Gwdb_driver.ifam list * Gwdb_driver.iper * int) list
option
(** Get the list of descendants up to or at level *)

425
lib/cousinsDisplay.ml Normal file
View File

@@ -0,0 +1,425 @@
(* Copyright (c) 1998-2007 INRIA *)
open Config
open Def
open Gwdb
open Util
open Cousins
let default_max_cnt = Cousins.default_max_cnt
(* there is a mismatch between cousins degree and "v1" parameter
which is the number of generation we go back to find a common ancestor *)
let _brother_label conf x =
match x with
| 1 -> transl conf "siblings"
| 2 -> transl conf "cousins"
| 3 -> transl conf "2nd cousins"
| 4 -> transl conf "3rd cousins"
| n ->
Printf.sprintf
(ftransl conf "%s cousins")
(transl_nth conf "nth (cousin)" (n - 1))
let cnt = ref 0
let cnt_sp = ref 0
let give_access conf base ~cnt_sp ia_asex p1 b1 p2 b2 =
let sps = Util.get_opt conf "sp" true in
let img = Util.get_opt conf "im" true in
let reference _ _ p (s : Adef.safe_string) =
if is_hidden p then s
else
Printf.sprintf {|<a href="%sm=RL&%s&b1=%s&%s&b2=%s%s%s&bd=%s">%s</a>|}
(commd conf :> string)
(acces_n conf base (Adef.escaped "1") p1 :> string)
(Sosa.to_string (Util.old_sosa_of_branch conf base (ia_asex :: b1)))
(acces_n conf base (Adef.escaped "2") p2 :> string)
(Sosa.to_string (Util.old_sosa_of_branch conf base (ia_asex :: b2)))
(if sps then "" else "&sp=0")
(if img then "" else "&im=0")
(Option.value ~default:(Adef.encoded "0") (List.assoc_opt "bd" conf.env)
:> string)
(s :> string)
|> Adef.safe
in
let reference_sp p3 _ _ p (s : Adef.safe_string) =
if is_hidden p then s
else
Printf.sprintf {|<a href="%sm=RL&%s&b1=%s&%s&b2=%s&%s%s%s&bd=%s">%s</a>|}
(commd conf :> string)
(acces_n conf base (Adef.escaped "1") p1 :> string)
(Sosa.to_string (Util.old_sosa_of_branch conf base (ia_asex :: b1)))
(acces_n conf base (Adef.escaped "2") p2 :> string)
(Sosa.to_string (Util.old_sosa_of_branch conf base (ia_asex :: b2)))
(acces_n conf base (Adef.escaped "4") p3 :> string)
(if sps then "" else "&sp=0")
(if img then "" else "&im=0")
(Option.value ~default:(Adef.encoded "0") (List.assoc_opt "bd" conf.env)
:> string)
(s :> string)
|> Adef.safe
in
let print_nospouse _ =
SosaCache.print_sosa conf base p2 true;
Output.print_string conf (gen_person_title_text reference conf base p2);
Output.print_string conf (DateDisplay.short_dates_text conf base p2)
in
let print_spouse sp first =
incr cnt_sp;
if first then (
SosaCache.print_sosa conf base p2 true;
Output.print_string conf (gen_person_title_text reference conf base p2))
else (
Output.print_sstring conf "<br>";
Output.print_string conf (person_title_text conf base p2));
Output.print_string conf (DateDisplay.short_dates_text conf base p2);
Output.print_sstring conf " &amp; ";
SosaCache.print_sosa conf base sp true;
Output.print_string conf
(gen_person_title_text (reference_sp sp) conf base sp);
Output.print_string conf (DateDisplay.short_dates_text conf base sp)
in
if p_getenv conf.env "spouse" = Some "on" then
match get_family p2 with
| [||] -> print_nospouse ()
| u ->
Array.iteri
(fun i ifam ->
let cpl = foi base ifam in
let sp =
if get_sex p2 = Female then pget conf base (get_father cpl)
else pget conf base (get_mother cpl)
in
print_spouse sp (i = 0))
u
else print_nospouse ()
let rec print_descend_upto conf base max_cnt ini_p ini_br lev children =
if lev > 0 && !cnt < max_cnt then (
Output.print_sstring conf "<ul>\n";
List.iter
(fun (ip, ia_asex, rev_br) ->
let p = pget conf base ip in
(* détecter l'époux de p, parent des enfants qui seront listés *)
let get_spouse base iper ifam =
let f = foi base ifam in
if iper = get_father f then poi base (get_mother f)
else poi base (get_father f)
in
(* if more than one spouse, this will be split on multiple lines *)
(* we ignore the case where two spouses, but only one with descendants! *)
let with_sp =
if Array.length (get_family p) = 1 then
let sp = get_spouse base ip (get_family p).(0) in
" " ^<^ Util.transl conf "with" ^<^ " "
^<^ person_title_text conf base sp
else Adef.safe ""
in
let br = List.rev ((ip, get_sex p) :: rev_br) in
let is_valid_rel = br_inter_is_empty ini_br br in
if is_valid_rel && !cnt < max_cnt && has_desc_lev conf base lev p then (
if lev <= 2 then (
Output.print_sstring conf "<li>";
if lev = 1 then (
give_access conf base ~cnt_sp ia_asex ini_p ini_br p br;
incr cnt)
else
let s : Adef.safe_string = person_title_text conf base p in
transl_a_of_gr_eq_gen_lev conf
(transl_nth conf "child/children" 1)
(s :> string)
(s :> string)
|> Util.translate_eval |> Utf8.capitalize_fst
|> Output.print_sstring conf;
Output.print_string conf with_sp;
Output.print_sstring conf (Util.transl conf ":");
Output.print_sstring conf
(if (with_sp :> string) = "" then "<br>" else " "));
(* the function children_of returns *all* the children of ip *)
Array.iter
(fun ifam ->
let children =
List.map
(fun i -> (i, ia_asex, (get_iper p, get_sex p) :: rev_br))
(children_of_fam base ifam)
in
let sp = get_spouse base ip ifam in
if
Array.length (get_family p) > 1
&& lev >= 2
&& List.length children > 0
&& has_desc_lev conf base lev sp
then (
Output.print_sstring conf (Util.transl conf "with");
Output.print_sstring conf " ";
Output.print_string conf (person_title_text conf base sp);
Output.print_sstring conf (Util.transl conf ":"));
print_descend_upto conf base max_cnt ini_p ini_br (lev - 1)
children)
(get_family p);
if lev <= 2 then Output.print_sstring conf "</li>"))
children;
Output.print_sstring conf "</ul>")
let print_cousins_side_of conf base max_cnt a ini_p ini_br lev1 lev2 =
let sib = siblings conf base (get_iper a) in
if List.exists (sibling_has_desc_lev conf base lev2) sib then (
if lev1 > 1 then (
Output.print_sstring conf "<li>";
[
(gen_person_title_text no_reference conf base a
: Adef.safe_string
:> string);
]
|> cftransl conf "on %s's siblings side"
|> Utf8.capitalize_fst |> Output.print_sstring conf;
Output.print_sstring conf (Util.transl conf ":"));
let sib = List.map (fun (ip, ia_asex) -> (ip, ia_asex, [])) sib in
print_descend_upto conf base max_cnt ini_p ini_br lev2 sib;
if lev1 > 1 then Output.print_sstring conf "</li>";
true)
else false
let print_cousins_lev conf base max_cnt p lev1 lev2 =
let first_sosa =
let rec loop sosa lev =
if lev <= 1 then sosa else loop (Sosa.twice sosa) (lev - 1)
in
loop Sosa.one lev1
in
let last_sosa = Sosa.twice first_sosa in
Util.print_tips_relationship conf;
if lev1 > 1 then Output.print_sstring conf "<ul>";
let some =
let rec loop sosa some =
if !cnt < max_cnt && Sosa.gt last_sosa sosa then
let some =
match Util.old_branch_of_sosa conf base (get_iper p) sosa with
| Some ((ia, _) :: _ as br) ->
print_cousins_side_of conf base max_cnt (pget conf base ia) p br
lev1 lev2
|| some
| _ -> some
in
loop (Sosa.inc sosa 1) some
else some
in
loop first_sosa false
in
if not some then (
Output.print_sstring conf (Utf8.capitalize_fst (transl conf "no match"));
Output.print_sstring conf ". ");
if lev1 > 1 then Output.print_sstring conf "</ul>"
(* HTML main *)
let print_cousins conf base p lev1 lev2 =
let title _h =
let cous12 = Format.sprintf "cousins.%d.%d" lev1 lev2 in
let cous_transl = Utf8.capitalize_fst (transl_nth conf cous12 1) in
if String.length cous_transl > 0 && cous_transl.[0] <> '[' then
Output.print_sstring conf cous_transl
else
Output.printf conf "%s %s / %s %s" (string_of_int lev1)
(transl_nth conf "ascending/descending (degree)"
(if lev1 = 1 then 0 else 2))
(string_of_int lev2)
(transl_nth conf "ascending/descending (degree)"
(if lev2 = 1 then 1 else 3))
in
let max_cnt =
try int_of_string (List.assoc "max_cousins" conf.base_env)
with Not_found | Failure _ -> default_max_cnt
in
Perso.interp_notempl_with_menu title "perso_header" conf base p;
Output.print_sstring conf "<div>";
(*include_templ conf "cousins_tools";*)
Output.print_sstring conf "<h3>";
title false;
Output.print_sstring conf "</h3>";
Output.print_sstring conf "</div>";
cnt := 0;
(* Construction de la table des sosa de la base *)
let () = SosaCache.build_sosa_ht conf base in
print_cousins_lev conf base max_cnt p lev1 lev2;
Output.print_sstring conf "<div><p>";
if !cnt >= max_cnt then Output.print_sstring conf "etc... "
else if !cnt > 1 then (
Output.print_sstring conf (Utf8.capitalize_fst (transl conf "total"));
Output.print_sstring conf (Util.transl conf ":");
Output.print_sstring conf " ";
Output.print_sstring conf (string_of_int !cnt);
Output.print_sstring conf " ";
Output.print_sstring conf
(Util.translate_eval ("@(c)" ^ transl_nth conf "person/persons" 1)));
if p_getenv conf.env "spouse" = Some "on" then (
Output.print_sstring conf " ";
Output.print_sstring conf (transl conf "and");
Output.print_sstring conf " ";
Output.print_sstring conf (string_of_int !cnt_sp);
Output.print_sstring conf " ";
Output.print_sstring conf
(Util.translate_eval ("@(c)" ^ transl_nth conf "spouse/spouses" 1));
Output.print_sstring conf ". ")
else Output.print_sstring conf ". ";
Output.print_sstring conf "</p></div>";
Hutil.trailer conf
(* TODO use Sosa module instead *)
let sosa_of_persons conf base =
let rec loop n = function
| [] -> n
| ip :: list ->
(* do no works if sex = Neuter *)
loop
(if get_sex (pget conf base ip) = Male then 2 * n else (2 * n) + 1)
list
in
loop 1
let print_anniv conf base p dead_people level =
let module S = Map.Make (struct
type t = iper
let compare = compare
end) in
let s_mem x m =
try
let _ = S.find x m in
true
with Not_found -> false
in
let rec insert_desc set up_sosa down_br n ip =
if s_mem ip set then set
else
let set = S.add ip (up_sosa, down_br) set in
if n = 0 then set
else
let u = get_family (pget conf base ip) in
let down_br = ip :: down_br in
let rec loop set i =
if i = Array.length u then set
else
let chil = get_children (foi base u.(i)) in
let set =
let rec loop set i =
if i = Array.length chil then set
else
let set = insert_desc set up_sosa down_br (n - 1) chil.(i) in
loop set (i + 1)
in
loop set 0
in
loop set (i + 1)
in
loop set 0
in
let set =
let module P = Pqueue.Make (struct
type t = iper * int * int
let leq (_, lev1, _) (_, lev2, _) = lev1 <= lev2
end) in
let a = P.add (get_iper p, 0, 1) P.empty in
let rec loop set a =
if P.is_empty a then set
else
let (ip, n, up_sosa), a = P.take a in
let set = insert_desc set up_sosa [] (n + 3) ip in
if n >= level then set
else
let a =
match get_parents (pget conf base ip) with
| Some ifam ->
let cpl = foi base ifam in
let n = n + 1 in
let up_sosa = 2 * up_sosa in
let a = P.add (get_father cpl, n, up_sosa) a in
P.add (get_mother cpl, n, up_sosa + 1) a
| None -> a
in
loop set a
in
loop S.empty a
in
let set =
S.fold
(fun ip (up_sosa, down_br) set ->
let u = get_family (pget conf base ip) in
let set = S.add ip (up_sosa, down_br, None) set in
if Array.length u = 0 then set
else
let rec loop set i =
if i = Array.length u then set
else
let cpl = foi base u.(i) in
let c = Gutil.spouse ip cpl in
loop (S.add c (up_sosa, down_br, Some ip) set) (i + 1)
in
loop set 0)
set S.empty
in
let txt_of (up_sosa, down_br, spouse) conf base c =
Printf.sprintf {|<a href="m=RL&%s&b1=%d&%s&b2=%d%s">%s</a>|}
(acces_n conf base (Adef.escaped "1") p :> string)
up_sosa
(acces_n conf base (Adef.escaped "2")
(Option.fold ~none:c ~some:(pget conf base) spouse)
:> string)
(sosa_of_persons conf base down_br)
(if spouse = None then
"&" ^ (acces_n conf base (Adef.escaped "4") c :> string)
else "")
(person_title_text conf base c :> string)
|> Adef.safe
in
let f_scan =
let list = ref (S.fold (fun ip b list -> (ip, b) :: list) set []) in
fun () ->
match !list with
| (x, b) :: l ->
list := l;
(pget conf base x, txt_of b)
| [] -> raise Not_found
in
let mode () =
Util.hidden_input conf "m" (Adef.encoded "C");
Util.hidden_input conf "i" (get_iper p |> string_of_iper |> Adef.encoded);
Util.hidden_input conf "t"
(Adef.encoded (if dead_people then "AD" else "AN"))
in
match p_getint conf.env "v" with
| Some i -> BirthdayDisplay.gen_print conf base i f_scan dead_people
| _ ->
if dead_people then
BirthdayDisplay.gen_print_menu_dead conf base f_scan mode
else BirthdayDisplay.gen_print_menu_birth conf base f_scan mode
let cousmenu_print = Perso.interp_templ "cousmenu"
let print conf base p =
let max_lvl = max_cousin_level conf in
(* v1 is the number of generation we go up to get a common ancestor,
v2 is the number of generation we go down from the ancestor.
e.g.
(v1,v2) = (1,1) are their sisters/brothers
(v1,v2) = (2,2) are their "cousins" *)
match
(p_getint conf.env "v1", p_getint conf.env "v2", p_getenv conf.env "t")
with
| Some 1, Some 1, _ | Some 0, _, _ | _, Some 0, _ ->
Perso.interp_templ "cousins" conf base p
| Some lvl1, _, _ ->
let lvl1 = min (max 1 lvl1) max_lvl in
let lvl2 =
match p_getint conf.env "v2" with
| Some lvl2 -> min (max 1 lvl2) max_lvl
| None -> lvl1
in
print_cousins conf base p lvl1 lvl2
| _, _, Some (("AN" | "AD") as t) when conf.wizard || conf.friend ->
print_anniv conf base p (t = "AD") max_lvl
| _ -> cousmenu_print conf base p

14
lib/cousinsDisplay.mli Normal file
View File

@@ -0,0 +1,14 @@
val print : Config.config -> Gwdb.base -> Gwdb.person -> unit
(** Displays the menu that lists all person's relatives depending on ancestor and his descandant levels
specified by [conf.env] variables {i v1} (for ancestor) and {i v2} for his descandant. For exemple :
"v1" = 1, "v2" = 1 - Displays all person's siblings (mount to the person's parent (ancestor of level 1)
and lists all his children (descandant of level 1));
"v1" = 2, "v2" = 2 - Displays all cousins;
"v1" = 2, "v2" = 1 - Displays all uncles/aunts;
"v1" = 1, "v2" = 2 - Displays all nieces/nephews;
etc.
Variable "t" is used to display anniversaries for relatives like [BirthdayDisplay.gen_print].
If nor of those variables are defined, prints menu that allows to access the most common relatives (except for direct relatives)
like cousins, siblings, uncles/aunts, etc. *)

141
lib/dag.ml Normal file
View File

@@ -0,0 +1,141 @@
open Config
open Dag2html
open Def
open Gwdb
open Util
(* TODO use a set.. *)
module Pset = struct
type t = iper list
type elt = iper
let add e s = if List.mem e s then s else e :: s
let empty = []
let elements s = List.rev s
let mem = List.mem
end
(* input dag *)
let get_dag_elems conf base =
let rec loop prev_po set i =
let s = string_of_int i in
let po = Util.find_person_in_env conf base s in
let po = match po with None -> prev_po | x -> x in
let so = Util.p_getenv conf.env ("s" ^ s) in
match (po, so) with
| Some p, Some s ->
let set =
match Util.branch_of_sosa conf base (Sosa.of_string s) p with
| Some ipsl ->
List.fold_left (fun set p -> Pset.add (get_iper p) set) set ipsl
| None -> set
in
loop po set (i + 1)
| _ -> set
in
loop None Pset.empty 1
type ('a, 'b) sum = ('a, 'b) Def.choice
let make_dag conf base set =
let list = Pset.elements set in
let module O = struct
type t = iper
let compare = compare
end in
let module M = Map.Make (O) in
let nodes = Array.of_list list in
let map =
let rec loop map i =
if i = Array.length nodes then map
else loop (M.add nodes.(i) (idag_of_int i) map) (i + 1)
in
loop M.empty 0
in
let nodes =
Array.map
(fun ip ->
let pare =
match get_parents (pget conf base ip) with
| Some ifam -> (
let c = foi base ifam in
let l =
try [ M.find (get_mother c) map ] with Not_found -> []
in
try M.find (get_father c) map :: l with Not_found -> l)
| None -> []
in
let chil =
let u = pget conf base ip in
Array.fold_left
(fun chil ifam ->
let des = foi base ifam in
Array.fold_left
(fun chil ip ->
try M.find ip map :: chil with Not_found -> chil)
chil (get_children des))
[] (get_family u)
in
let chil = List.rev chil in
{ pare; valu = Left ip; chil })
nodes
in
let nodes =
let rec loop nodes n i =
if i = Array.length nodes then nodes
else
match nodes.(i) with
| { valu = Left ip; chil } ->
let ifaml = Array.to_list (get_family (pget conf base ip)) in
let nodes, n =
let rec loop nodes = function
| ifam :: ifaml -> (
let cpl = foi base ifam in
let isp = Gutil.spouse ip cpl in
let jdo =
try Some (M.find isp map) with Not_found -> None
in
match jdo with
| Some jd ->
let j = int_of_idag jd in
if chil = [] && nodes.(j).chil = [] then (
let pare = [ idag_of_int i; jd ] in
let d = { pare; valu = Right n; chil = [] } in
let nodes = Array.append nodes [| d |] in
let nd = idag_of_int n in
nodes.(i).chil <- [ nd ];
nodes.(j).chil <- [ nd ];
(nodes, n + 1))
else if chil <> nodes.(j).chil then (
List.iter
(fun nd ->
if List.mem nd nodes.(j).chil then ()
else
let n = int_of_idag nd in
nodes.(j).chil <- nd :: nodes.(j).chil;
nodes.(n).pare <- jd :: nodes.(n).pare)
chil;
List.iter
(fun nd ->
if List.mem nd chil then ()
else
let id = idag_of_int i in
let n = int_of_idag nd in
nodes.(i).chil <- nd :: chil;
nodes.(n).pare <- id :: nodes.(n).pare)
nodes.(j).chil;
loop nodes ifaml)
else loop nodes ifaml
| None -> loop nodes ifaml)
| [] -> (nodes, n)
in
loop nodes ifaml
in
loop nodes n (i + 1)
| _ -> loop nodes n (i + 1)
in
loop nodes (Array.length nodes) 0
in
{ dag = nodes }

20
lib/dag.mli Normal file
View File

@@ -0,0 +1,20 @@
(* TODOCP *)
module Pset : sig
type t = Gwdb.iper list
type elt = Gwdb.iper
val add : 'a -> 'a list -> 'a list
val empty : 'a list
val elements : 'a list -> 'a list
val mem : 'a -> 'a list -> bool
end
val get_dag_elems : Config.config -> Gwdb.base -> Gwdb.iper list
type ('a, 'b) sum = ('a, 'b) Def.choice
val make_dag :
Config.config ->
Gwdb.base ->
Gwdb.iper list ->
(Gwdb.iper, int) Def.choice Dag2html.dag

1417
lib/dag2html.ml Normal file
View File

File diff suppressed because it is too large Load Diff

40
lib/dag2html.mli Normal file
View File

@@ -0,0 +1,40 @@
(* $Id: dag2html.mli,v 5.0 2005-12-13 11:51:26 ddr Exp $ *)
open Gwdb
(* TODOCP *)
type 'a dag = { mutable dag : 'a node array }
and 'a node = { mutable pare : idag list; valu : 'a; mutable chil : idag list }
and idag
external int_of_idag : idag -> int = "%identity"
external idag_of_int : int -> idag = "%identity"
type 'a table = { mutable table : 'a data array array }
and 'a data = { mutable elem : 'a elem; mutable span : span_id }
and 'a elem = Elem of 'a | Ghost of ghost_id | Nothing
and span_id
and ghost_id
type align = LeftA | CenterA | RightA
type 'a table_data =
| TDitem of iper * 'a * Adef.safe_string
| TDtext of iper * Adef.safe_string
| TDhr of align
| TDbar of Adef.escaped_string option
| TDnothing
type 'a html_table_line = (int * align * 'a table_data) array
type 'a html_table = 'a html_table_line array
val html_table_struct :
('a node -> iper) ->
('a node -> 'b) ->
('a node -> Adef.escaped_string) ->
('a node -> bool) ->
'a dag ->
idag table ->
(int * align * 'b table_data) array array
val table_of_dag :
('a node -> bool) -> bool -> bool -> bool -> 'a dag -> idag table

1373
lib/dagDisplay.ml Normal file
View File

File diff suppressed because it is too large Load Diff

40
lib/dagDisplay.mli Normal file
View File

@@ -0,0 +1,40 @@
(* TODOOCP *)
val image_txt : Config.config -> Gwdb.base -> Gwdb.person -> Adef.safe_string
type item = Item of Gwdb.person * Adef.safe_string
val make_tree_hts :
Config.config ->
Gwdb.base ->
(Gwdb.person -> item) ->
(Gwdb.iper -> Adef.escaped_string) ->
bool ->
Gwdb.iper list ->
(Gwdb.iper * (Gwdb.iper * Gwdb.ifam option)) list ->
(Gwdb.iper, 'a) Def.choice Dag2html.dag ->
(int * Dag2html.align * Adef.safe_string Dag2html.table_data) array array
(** [make_tree_hts conf base elem_txt vbar_txt invert set spl d] *)
val print_slices_menu_or_dag_page :
Config.config ->
Gwdb.base ->
Adef.safe_string ->
(int * Dag2html.align * Adef.safe_string Dag2html.table_data) array array ->
Adef.escaped_string ->
unit
(** [print_slices_menu_or_dag_page conf page_title hts next_txt] *)
val make_and_print_dag :
Config.config ->
Gwdb.base ->
(Gwdb.person -> item) ->
(Gwdb.iper -> Adef.escaped_string) ->
bool ->
Gwdb.iper list ->
(Gwdb.iper * (Gwdb.iper * Gwdb.ifam option)) list ->
Adef.safe_string ->
Adef.escaped_string ->
unit
(** [make_and_print_dag conf base elem_txt vbar_txt invert set spl page_title next_txt] *)
val print : Config.config -> Gwdb.base -> unit

675
lib/dateDisplay.ml Normal file
View File

@@ -0,0 +1,675 @@
(* Copyright (c) 1998-2007 INRIA *)
open Config
open Def
open Util
open Gwdb
let get_wday conf = function
| Dgreg (({ prec = Sure; delta = 0 } as d), _) when d.day <> 0 && d.month <> 0
->
let jd = Calendar.sdn_of_gregorian d in
let wday =
let jd_today = Calendar.sdn_of_gregorian conf.today in
let x = conf.today_wd - jd_today + jd in
if x < 0 then 6 + ((x + 1) mod 7) else x mod 7
in
" (" ^ transl_nth conf "(week day)" wday ^ ")"
| _ -> ""
let death_symbol conf =
try List.assoc "death_symbol" conf.base_env with Not_found -> "†"
let code_date conf encoding d m y =
let apply_date_code = function
| 'd' -> string_of_int d
| 'm' -> transl_nth conf "(month)" (m - 1)
| 'y' -> string_of_int y
| c -> "%" ^ String.make 1 c
in
let rec loop i =
if i = String.length encoding then ""
else
let s, i =
match encoding.[i] with
| '%' when i + 1 < String.length encoding ->
let s = apply_date_code encoding.[i + 1] in
(s, i + 1)
| '[' -> (
try
(* code similar to Util.gen_decline *)
let len = String.length encoding in
let j = String.index_from encoding i ']' in
let k = String.index_from encoding i '|' in
if k < j && j + 2 < len && encoding.[j + 1] = '%' then
let s = apply_date_code encoding.[j + 2] in
let s1 =
if start_with_vowel conf s then
String.sub encoding (k + 1) (j - k - 1)
else String.sub encoding (i + 1) (k - i - 1)
in
(s1 ^ s, j + 2)
else (String.make 1 '[', i)
with Not_found -> (String.make 1 '[', i))
| c -> (String.make 1 c, i)
in
s ^ loop (i + 1)
in
loop 0
let code_dmy conf d =
let encoding =
let n =
if d.day = 1 then 0
else if d.day != 0 then 1
else if d.month != 0 then 2
else 3
in
transl_nth conf "(date)" n
in
code_date conf encoding d.day d.month d.year
let default_french_month =
let tab =
[|
"Vendemiaire";
"Brumaire";
"Frimaire";
"Nivose";
"Pluviose";
"Ventose";
"Germinal";
"Floreal";
"Prairial";
"Messidor";
"Thermidor";
"Fructidor";
"Extra";
|]
in
fun m -> tab.(m)
let default_hebrew_month =
let tab =
[|
"Tishri";
"Heshvan";
"Kislev";
"Tevet";
"Shevat";
"AdarI";
"AdarII";
"Nisan";
"Iyyar";
"Sivan";
"Tammuz";
"Av";
"Elul";
|]
in
fun m -> tab.(m)
let french_month conf m =
let r = transl_nth conf "(french revolution month)" m in
if r = "[(french revolution month)]" then "[" ^ default_french_month m ^ "]"
else r
let hebrew_month conf m =
let r = transl_nth conf "(hebrew month)" m in
if r = "[(hebrew month)]" then "[" ^ default_hebrew_month m ^ "]" else r
let code_french_year conf y =
transl_nth conf "year/month/day" 3
^ " "
^ if y >= 1 && y < 4000 then Mutil.roman_of_arabian y else string_of_int y
let code_french_date conf d m y =
let s =
if d = 0 then ""
else string_of_int d ^ if d = 1 then "<sup>er</sup>" else ""
in
let s =
if m = 0 then ""
else s ^ (if s = "" then "" else " ") ^ french_month conf (m - 1)
in
s ^ (if s = "" then "" else " ") ^ code_french_year conf y
let code_hebrew_date conf d m y =
let s = if d = 0 then "" else string_of_int d in
let s =
if m = 0 then ""
else s ^ (if s = "" then "" else " ") ^ hebrew_month conf (m - 1)
in
s ^ (if s = "" then "" else " ") ^ string_of_int y
let string_of_on_prec_dmy_aux conf sy sy2 d =
match d.prec with
| Sure ->
if d.day = 0 && d.month = 0 then transl conf "in (year)" ^ " " ^ sy
else if d.day = 0 then transl_decline conf "in (month year)" sy
else transl_decline conf "on (day month year)" sy
| About | Before | After ->
let s = sy in
if d.prec = About then transl_decline conf "about (date)" s
else if d.prec = Before then transl_decline conf "before (date)" s
else transl_decline conf "after (date)" s
| Maybe ->
let s =
if d.day = 0 && d.month = 0 then transl conf "in (year)" ^ " " ^ sy
else if d.day = 0 then transl_decline conf "in (month year)" sy
else transl_decline conf "on (day month year)" sy
in
transl_decline conf "possibly (date)" s
| OrYear d2 ->
let s =
if d.day = 0 && d.month = 0 then transl conf "in (year)" ^ " " ^ sy
else if d.day = 0 then transl_decline conf "in (month year)" sy
else transl_decline conf "on (day month year)" sy
in
let s2 =
if d2.day2 = 0 && d2.month2 = 0 then transl conf "in (year)" ^ " " ^ sy2
else if d2.day2 = 0 then transl_decline conf "in (month year)" sy2
else transl_decline conf "on (day month year)" sy2
in
s ^ " " ^ transl conf "or" ^ " " ^ Mutil.nominative s2
| YearInt d2 ->
let s =
if d.day = 0 && d.month = 0 then sy
else if d.day = 0 then sy
else transl_decline conf "on (day month year)" sy
in
let s2 =
if d2.day2 = 0 && d2.month2 = 0 then sy2
else if d2.day2 = 0 then sy2
else transl_decline conf "on (day month year)" sy2
in
transl conf "between (date)"
^ " " ^ s ^ " " ^ transl_nth conf "and" 0 ^ " " ^ Mutil.nominative s2
let replace_spaces_by_nbsp s =
let rec loop i len =
if i = String.length s then Buff.get len
else if s.[i] = ' ' then loop (i + 1) (Buff.mstore len "&nbsp;")
else loop (i + 1) (Buff.store len s.[i])
in
loop 0 0
let string_of_on_prec_dmy conf sy sy2 d =
Adef.safe
@@
let r = string_of_on_prec_dmy_aux conf sy sy2 d in
replace_spaces_by_nbsp r
let string_of_on_french_dmy conf d =
let sy = code_french_date conf d.day d.month d.year in
let sy2 =
match d.prec with
| OrYear d2 | YearInt d2 -> code_french_date conf d2.day2 d2.month2 d2.year2
| _ -> ""
in
string_of_on_prec_dmy conf sy sy2 d
let string_of_on_hebrew_dmy conf d =
let sy = code_hebrew_date conf d.day d.month d.year in
let sy2 =
match d.prec with
| OrYear d2 | YearInt d2 -> code_hebrew_date conf d2.day2 d2.month2 d2.year2
| _ -> ""
in
string_of_on_prec_dmy conf sy sy2 d
let string_of_prec_dmy conf s s2 d =
Adef.safe
@@
match d.prec with
| Sure -> Mutil.nominative s
| About -> transl_decline conf "about (date)" s
| Before -> transl_decline conf "before (date)" s
| After -> transl_decline conf "after (date)" s
| Maybe -> transl_decline conf "possibly (date)" s
| OrYear _ -> s ^ " " ^ transl conf "or" ^ " " ^ Mutil.nominative s2
| YearInt _ ->
transl conf "between (date)"
^ " " ^ s ^ " " ^ transl_nth conf "and" 0 ^ " " ^ Mutil.nominative s2
let string_of_dmy_aux fn conf d =
let sy = code_dmy conf d in
let sy2 =
match d.prec with
| OrYear d2 | YearInt d2 -> code_dmy conf (Date.dmy_of_dmy2 d2)
| _ -> ""
in
fn conf sy sy2 d
let string_of_on_dmy conf d = string_of_dmy_aux string_of_on_prec_dmy conf d
let string_of_dmy conf d = string_of_dmy_aux string_of_prec_dmy conf d
(* ************************************************************************ *)
(* [Fonc] translate_dmy : config -> (string * string * string) ->
calendar -> bool -> (string * string * string) *)
(* ************************************************************************ *)
(** [Description] : Traduit en fonction du calendrier, le mois et/ou l'année
d'une date et renvoie le triplet conformément au format
de la date.
[Args] :
- conf : configuration de la base
- (fst, snd, trd) : la date au bon format
- cal : calendar
- short : booléen pour savoir si on affiche au format court, e.g.
VD/Vendémiaire
[Retour] : (string * string * string) : date traduite
[Rem] : Non exporté en clair hors de ce module. *)
let translate_dmy conf (fst, snd, trd) cal short =
let translate_month m =
match cal with
| Dfrench when m <> "" ->
if short then Util.short_f_month (int_of_string m)
else french_month conf (int_of_string m)
| Dhebrew when m <> "" ->
if short then
String.uppercase_ascii
(String.sub (hebrew_month conf (int_of_string m)) 0 2)
else hebrew_month conf (int_of_string m)
| _ -> m
in
let translate_year y =
match cal with
| Dfrench ->
let y1 = int_of_string y in
if y1 >= 1 && y1 < 4000 then Mutil.roman_of_arabian y1 else y
| _ -> y
in
match transl conf "!dates order" with
| "yymmdd" | "yyyymmdd" -> (translate_year fst, translate_month snd, trd)
| "mmddyyyy" -> (translate_month fst, snd, translate_year trd)
| _ -> (fst, translate_month snd, translate_year trd)
(** [decode_dmy conf dmy]
Returns a triplet corresponding to day/month/year, arranged in
the order defined by [!dates order] keyword in the lexicon.
Supported formats are: "dmyyyy" / "mmddyyyy" / "yyyymmdd" / "ddmmyyyy" and "ddmmyy".
NB: "yy" and "yyyy" variants will produce the same output ([string_of_int] without padding)
If the format is not supported "ddmmyyyy" is used.
*)
let decode_dmy conf d =
match transl conf "!dates order" with
| "dmyyyy" ->
(string_of_int d.day, string_of_int d.month, string_of_int d.year)
| "mmddyyyy" -> (
(* Si le jour et/ou le mois n'est pas sur 2 caractères, *)
(* on rajoute les 0 nécessaires. *)
match (d.day, d.month, d.year) with
| 0, 0, year -> ("", "", string_of_int year)
| 0, month, year ->
let m = Printf.sprintf "%02d" month in
(m, "", string_of_int year)
| day, month, year ->
let d = Printf.sprintf "%02d" day in
let m = Printf.sprintf "%02d" month in
(m, d, string_of_int year))
| "yyyymmdd" | "yymmdd" -> (
(* Si le jour et/ou le mois n'est pas sur 2 caractères, *)
(* on rajoute les 0 nécessaires. *)
match (d.day, d.month, d.year) with
| 0, 0, year -> (string_of_int year, "", "")
| 0, month, year ->
let m = Printf.sprintf "%02d" month in
(string_of_int year, m, "")
| day, month, year ->
let d = Printf.sprintf "%02d" day in
let m = Printf.sprintf "%02d" month in
(string_of_int year, m, d))
| "ddmmyyyy" | "ddmmyy" | _ -> (
(* Si le jour et/ou le mois n'est pas sur 2 caractères, *)
(* on rajoute les 0 nécessaires. *)
match (d.day, d.month, d.year) with
| 0, 0, year -> ("", "", string_of_int year)
| 0, month, year ->
let m = Printf.sprintf "%02d" month in
("", m, string_of_int year)
| day, month, year ->
let d = Printf.sprintf "%02d" day in
let m = Printf.sprintf "%02d" month in
(d, m, string_of_int year))
let gregorian_precision conf d =
if d.delta = 0 then string_of_dmy conf d
else
let d2 =
Calendar.gregorian_of_sdn d.prec (Calendar.sdn_of_gregorian d + d.delta)
in
Adef.safe
@@ transl conf "between (date)"
^ " "
^ (string_of_on_dmy conf d :> string)
^ " " ^ transl_nth conf "and" 0 ^ " "
^ (string_of_on_dmy conf d2 :> string)
let string_of_date_aux ?(link = true) ?(dmy = string_of_dmy)
?(sep = Adef.safe " ") conf =
let mk_link c d (s : Adef.safe_string) =
Adef.safe
@@ Printf.sprintf
{|<a href="%sm=CAL&y%c=%d&m%c=%d&d%c=%d&t%c=1" class="date">%s</a>|}
(commd conf :> string)
c d.year c d.month c d.day c
(s :> string)
in
function
| Dgreg (d, Dgregorian) ->
let s = dmy conf d in
if link && d.day > 0 then mk_link 'g' d s else s
| Dgreg (d, Djulian) ->
let cal_prec =
if d.year < 1582 then Adef.safe ""
else " (" ^<^ gregorian_precision conf d ^>^ ")"
in
let d1 = Calendar.julian_of_gregorian d in
let year_prec =
if
(d1.month > 0 && d1.month < 3)
|| (d1.month = 3 && d1.day > 0 && d1.day < 25)
then Printf.sprintf " (%d/%d)" (d1.year - 1) (d1.year mod 10)
else ""
in
let s =
dmy conf d1 ^^^ year_prec ^<^ sep
^^^ transl_nth conf "gregorian/julian/french/hebrew" 1
^<^ cal_prec
in
if link && d1.day > 0 then mk_link 'j' d1 s else s
| Dgreg (d, Dfrench) -> (
let d1 = Calendar.french_of_gregorian d in
let s = string_of_on_french_dmy conf d1 in
let s = if link && d1.day > 0 then mk_link 'f' d1 s else s in
match d.prec with
| Sure | About | Before | After | Maybe ->
s ^^^ sep ^^^ " (" ^<^ gregorian_precision conf d ^>^ ")"
| OrYear _ | YearInt _ -> s)
| Dgreg (d, Dhebrew) -> (
let d1 = Calendar.hebrew_of_gregorian d in
let s = string_of_on_hebrew_dmy conf d1 in
match d.prec with
| Sure | About | Before | After | Maybe ->
s ^^^ sep ^^^ " (" ^<^ gregorian_precision conf d ^>^ ")"
| OrYear _ | YearInt _ -> s)
| Dtext t -> "(" ^<^ (Util.escape_html t :> Adef.safe_string) ^>^ ")"
let string_of_ondate ?link conf d =
(string_of_date_aux ?link ~dmy:string_of_on_dmy conf d :> string)
|> Util.translate_eval |> Adef.safe
let string_of_date conf = function
| Dgreg (d, _) -> string_of_dmy conf d
| Dtext t -> (Util.escape_html t :> Adef.safe_string)
let string_slash_of_date conf date =
let rec slashify_dmy (fst, snd, trd) d =
let code fst snd trd =
List.fold_right
(fun s accu -> if s <> "" then s ^ "/" ^ accu else accu)
[ fst; snd ] trd
in
match d.prec with
| OrYear d2 ->
let sy = code fst snd trd in
let d2 = Date.dmy_of_dmy2 d2 in
let sy2 = slashify_dmy (decode_dmy conf d2) d2 in
sy ^ " " ^ transl conf "or" ^ " " ^ sy2
| YearInt d2 ->
let sy = code fst snd trd in
let d2 = Date.dmy_of_dmy2 d2 in
let sy2 = slashify_dmy (decode_dmy conf d2) d2 in
transl conf "between (date)"
^ " " ^ sy ^ " " ^ transl_nth conf "and" 0 ^ " " ^ sy2
| _ ->
let sy = code fst snd trd in
(string_of_prec_dmy conf sy "" d :> string)
in
match date with
| Dtext t -> (Util.escape_html t :> Adef.safe_string)
| Dgreg (d, cal) -> (
Adef.safe
@@
match cal with
| Dgregorian -> slashify_dmy (decode_dmy conf d) d
| Djulian ->
let d1 = Calendar.julian_of_gregorian d in
slashify_dmy (translate_dmy conf (decode_dmy conf d1) Djulian true) d1
^ " ("
^ transl_nth conf "gregorian/julian/french/hebrew" 1
^ ")"
| Dfrench ->
let d1 = Calendar.french_of_gregorian d in
slashify_dmy (translate_dmy conf (decode_dmy conf d1) Dfrench true) d1
| Dhebrew ->
let d1 = Calendar.french_of_gregorian d in
slashify_dmy (translate_dmy conf (decode_dmy conf d1) Dhebrew true) d1
^ " ("
^ transl_nth conf "gregorian/julian/french/hebrew" 3
^ ")")
let string_of_age conf a =
Adef.safe
@@
match a with
| { day = 0; month = 0; year = y } ->
if y > 1 then string_of_int y ^ " " ^ transl conf "years old"
else if y = 1 then transl conf "one year old"
else transl conf "birth"
| { day = 0; month = m; year = y } ->
if y >= 2 then string_of_int y ^ " " ^ transl conf "years old"
else if y > 0 || m > 1 then
string_of_int ((y * 12) + m) ^ " " ^ transl conf "months old"
else if m = 1 then transl conf "one month old"
else transl conf "less than one month old"
| { day = d; month = m; year = y } ->
if y >= 2 then string_of_int y ^ " " ^ transl conf "years old"
else if y > 0 || m > 1 then
string_of_int ((y * 12) + m) ^ " " ^ transl conf "months old"
else if m = 1 then transl conf "one month old"
else if d >= 2 then string_of_int d ^ " " ^ transl conf "days old"
else if d = 1 then transl conf "one day old"
else "0"
(* ************************************************************************ *)
(* [Fonc] prec_text : config -> Def.dmy -> string *)
(* ************************************************************************ *)
(** [Description] : Renvoie la précision d'une date.
[Args] :
- conf : configuration de la base
- d : Def.dmy
[Retour] : string
[Rem] : Exporté en clair hors de ce module. *)
let prec_text conf d =
match d.prec with
| About -> (
(* On utilise le dictionnaire pour être sur *)
(* que ce soit compréhensible de tous. *)
match transl conf "about (short date)" with "ca" -> "ca " | s -> s)
| Maybe -> "?"
| Before -> "<"
| After -> ">"
| OrYear _ -> "|"
| YearInt _ -> ".."
| Sure -> ""
(* ************************************************************************ *)
(* [Fonc] month_text : Def.dmy -> string *)
(* ************************************************************************ *)
(** [Description] : Renvoie le mois d'une date.
[Args] :
- d : Def.dmy
[Retour] : string
[Rem] : Exporté en clair hors de ce module. *)
let month_text d = if d.month = 0 then "" else string_of_int d.month
(* ************************************************************************ *)
(* [Fonc] year_text : Def.dmy -> string *)
(* ************************************************************************ *)
(** [Description] : Renvoie l'année d'une date.
[Args] :
- d : Def.dmy
[Retour] : string
[Rem] : Exporté en clair hors de ce module. *)
let year_text d =
match d.prec with
| OrYear d2 when d.year <> d2.year2 ->
string_of_int d.year ^ "/" ^ string_of_int d2.year2
| YearInt d2 when d.year <> d2.year2 ->
string_of_int d.year ^ ".." ^ string_of_int d2.year2
| _ -> string_of_int d.year
(* ************************************************************************ *)
(* [Fonc] prec_year_text : config -> Def.dmy -> string *)
(* ************************************************************************ *)
(** [Description] : Renvoie la précision d'une date et l'année de la date.
[Args] :
- conf : configuration de la base
- d : Def.dmy
[Retour] : string
[Rem] : Exporté en clair hors de ce module. *)
let prec_year_text conf d =
let s =
match d.prec with
| About -> (
(* On utilise le dictionnaire pour être sur *)
(* que ce soit compréhensible de tous. *)
match transl conf "about (short date)" with "ca" -> "ca " | s -> s)
| Maybe -> "?"
| Before -> "/"
| _ -> ""
in
let s = s ^ year_text d in
match d.prec with After -> s ^ "/" | _ -> s
(* ********************************************************************** *)
(* [Fonc] short_dates_text : config -> base -> person -> string *)
(* ********************************************************************** *)
(** [Description] : Renvoie la concatenation de l'année de naissance et
l'année de décès (si trouvée par get_birth_death_date). La précision
de la date est ajoutée pour chaque année.
L'affichage est le suivant :
* 1700-1780 (date naissance - date décès)
* 1700- (naissance - décédé)
* 1700 (naissance - vivant)
* †1780 (pas date naissance - date décès)
* † (pas date naissance - décédé)
[Args] :
- conf : configuration de la base
- base : base de donnée
- p : person
[Retour] : string
[Rem] : Exporté en clair hors de ce module. *)
let short_dates_text conf base p =
Adef.safe
@@
if authorized_age conf base p then
let birth_date, death_date, _ = Gutil.get_birth_death_date p in
let s =
match (birth_date, death_date) with
| Some (Dgreg (b, _)), Some (Dgreg (d, _)) ->
prec_year_text conf b ^ "-" ^ prec_year_text conf d
| Some (Dgreg (b, _)), _ -> (
(* La personne peut être décédée mais ne pas avoir de date. *)
match get_death p with
| Death (_, _) | DeadDontKnowWhen | DeadYoung ->
prec_year_text conf b ^ "-"
| _ -> prec_year_text conf b)
| _, Some (Dgreg (d, _)) -> death_symbol conf ^ prec_year_text conf d
| _, _ -> (
(* La personne peut être décédée mais ne pas avoir de date. *)
match get_death p with
| Death (_, _) | DeadDontKnowWhen | DeadYoung -> death_symbol conf
| _ -> "")
in
if s <> "" then " <bdo dir=\"ltr\">" ^ s ^ "</bdo>" else s
else ""
(* ********************************************************************** *)
(* [Fonc] short_marriage_date_text :
config -> base -> person -> person -> string *)
(* ********************************************************************** *)
(** [Description] : Renvoie l'année de la date de mariage ansi que la
précision de la date.
[Args] :
- conf : configuration de la base
- base : base de donnée
- p1 : conjoint 1
- p2 : conjoint 2
[Retour] : string
[Rem] : Exporté en clair hors de ce module. *)
let short_marriage_date_text conf base fam p1 p2 =
Adef.safe
@@
if authorized_age conf base p1 && authorized_age conf base p2 then
match Date.cdate_to_dmy_opt (get_marriage fam) with
| Some d ->
"<span style=\"font-size:70%\">" ^ prec_year_text conf d ^ "</span>"
| None -> ""
else ""
(* ********************************************************************** *)
(* [Fonc] short_family_date_text :
config -> base -> bool -> family -> string *)
(* ********************************************************************** *)
(** [Description] : Renvoie l'année marriage - séparation
ou uniquement l'année de la séparation.
[Args] :
- conf : configuration de la base
- base : base de donnée
- bool : si faux, uniquement dates de la séparation
- family : famille
[Retour] : string
[Rem] : Exporté en clair hors de ce module. *)
let short_family_dates_text conf _base marr_sep fam =
let marr_dates_aux =
match Date.cdate_to_dmy_opt (Gwdb.get_marriage fam) with
| Some dmy -> Some (prec_year_text conf dmy)
| None -> Some ""
in
let sep_dates_aux =
match
List.find_opt
(fun e ->
e.efam_name = Efam_Divorce
|| e.efam_name = Efam_Annulation
|| e.efam_name = Efam_Separated)
(Gwdb.get_fevents fam)
with
| None -> None
| Some e -> (
match Date.cdate_to_dmy_opt e.efam_date with
| None -> Some ""
| Some dmy -> Some (prec_year_text conf dmy))
in
Adef.safe
@@
if marr_sep then
match (marr_dates_aux, sep_dates_aux) with
| Some m, Some s -> m ^ "-" ^ s
| Some m, None -> m
| None, _ -> ""
else Option.value ~default:"" sep_dates_aux
(* For public interfce, force [string_of_prec_dmy] args to be safe strings *)
let string_of_prec_dmy conf s s2 d =
let s = (s : Adef.safe_string :> string) in
let s2 = (s2 : Adef.safe_string :> string) in
string_of_prec_dmy conf s s2 d

118
lib/dateDisplay.mli Normal file
View File

@@ -0,0 +1,118 @@
(* Copyright (c) 1998-2007 INRIA *)
open Config
open Def
open Gwdb
val get_wday : config -> date -> string
(** [get_wday conf date]
Return the day of the week for this [date] *)
val code_dmy : config -> dmy -> string
(** Returns textual representation of the date translated to the current language.
Uses different encodings depending on day's, month's and year's accessibility.
Doesn't consider precision. *)
val code_hebrew_date : config -> int -> int -> int -> string
(** Returns textual representation of a day / month / year in the hebrew calendar
translated to the current language.
*)
val string_of_dmy : Config.config -> Def.dmy -> Adef.safe_string
(** Converts and translate date to the textual representation for the giving language. Considers precision. *)
val string_of_date : config -> date -> Adef.safe_string
(** If date is [Dgreg] calls for [string_of_dmy] to convert date to the string else returns content of [Dtext].
Difference between calendars is not taken into the acount. *)
val string_of_ondate : ?link:bool -> config -> date -> Adef.safe_string
(** Converts and translate date with considering different calendars with prefix "on"
before dates (changes for other languages).
Date precision is much more verbose then with [string_of_date]. Decline phrase if needed.
If [link] is true then encapsulates result in HTML link to the page calendar's date converter. *)
val string_of_on_french_dmy : config -> dmy -> Adef.safe_string
(** Translate a date in the french calendar
with prefix "on" before dates (changes for other languages). *)
val string_of_on_hebrew_dmy : config -> dmy -> Adef.safe_string
(** Translate a date in the hebrew calendar
with prefix "on" before dates (changes for other languages). *)
val string_slash_of_date : config -> date -> Adef.safe_string
(** Returns date in format dd/mm/yyyy. Format could be different for other languages (defined by [!dates order]
keyword in the lexicon). *)
val string_of_age : config -> dmy -> Adef.safe_string
(** Returns textual representation of the age represented by [dmy]. *)
val prec_year_text : config -> dmy -> string
(** Returns textual representation of date's precision and year. *)
val prec_text : config -> dmy -> string
(** Returns textual representation of date's precision *)
val month_text : dmy -> string
(** Returns textual representation of date's month number. *)
val year_text : dmy -> string
(** Returns textual representation of date's year. *)
val short_dates_text : config -> base -> person -> Adef.safe_string
(** Returns concatenation of person's birth and death dates (if exists). Precision is mentionned for each date.
For example :
* 1700-1780 (birth - death)
* 1700- (birth - death but don't know when)
* 1700 (birth - alive)
* †1780 (unknown birth date - death)
* † (unknown birth date - death but don't know when) *)
val short_marriage_date_text :
config -> base -> family -> person -> person -> Adef.safe_string
(** Retruns year of marriage for given spouses with its precision. *)
val short_family_dates_text :
config -> base -> bool -> family -> Adef.safe_string
(** Retruns years of marriage (yyy1-yyy2) for given family taking
into account possible separation or divorce. *)
val death_symbol : config -> string
(** [death_symbol conf]
Return the value associated to ["death_symbol"] in [.gwf] file
if it is defined, or use ["†"] if it is not.
*)
val code_french_year : config -> int -> string
(** Returns roman number of the year of French calendar *)
val string_of_date_aux :
?link:bool ->
?dmy:(Config.config -> Def.dmy -> Adef.safe_string) ->
?sep:Adef.safe_string ->
Config.config ->
Def.date ->
Adef.safe_string
(** Same as [string_of_ondate] except :
- Conversion function for [Def.dmy] could be passed in in [dmy] argument
- Doesn't consider phrase declination as [string_of_ondate] does. *)
(**/**)
val hebrew_month : config -> int -> string
(** Returns the translation of the month of French calendar
First month is [0]
*)
val french_month : config -> int -> string
(** Returns the translation of the month of Hebrew calendar
First month is [0]
*)
val string_of_prec_dmy :
config -> Adef.safe_string -> Adef.safe_string -> dmy -> Adef.safe_string
(** [string_of_prec_dmy conf s s2 d]
Takes two date representations (as strings) [s] and [s2] and
returns translated phrase according to prec of [d].
[d] is only used to determine the precision
*)

79
lib/def/adef.ml Normal file
View File

@@ -0,0 +1,79 @@
(* $Id: adef.ml,v 5.6 2007-02-21 18:14:01 ddr Exp $ *)
(* Copyright (c) 1998-2007 INRIA *)
type fix = int
let float_of_fix x = float x /. 1000000.0
let fix_of_float x = truncate ((x *. 1000000.0) +. 0.5)
external fix : int -> fix = "%identity"
external fix_repr : fix -> int = "%identity"
let no_consang = fix (-1)
type date = Dgreg of dmy * calendar | Dtext of string
and calendar = Dgregorian | Djulian | Dfrench | Dhebrew
and dmy = { day : int; month : int; year : int; prec : precision; delta : int }
and dmy2 = { day2 : int; month2 : int; year2 : int; delta2 : int }
and precision =
| Sure
| About
| Maybe
| Before
| After
| OrYear of dmy2
| YearInt of dmy2
type cdate =
| Cgregorian of int
| Cjulian of int
| Cfrench of int
| Chebrew of int
| Ctext of string
| Cdate of date
| Cnone
type 'person gen_couple = { father : 'person; mother : 'person }
and 'person gen_parents = { parent : 'person array }
let father cpl =
if Obj.size (Obj.repr cpl) = 2 then cpl.father else (Obj.magic cpl).parent.(0)
let mother cpl =
if Obj.size (Obj.repr cpl) = 2 then cpl.mother else (Obj.magic cpl).parent.(1)
let couple father mother = { father; mother }
let parent parent = { father = parent.(0); mother = parent.(1) }
let parent_array cpl =
if Obj.size (Obj.repr cpl) = 2 then [| cpl.father; cpl.mother |]
else (Obj.magic cpl).parent
let multi_couple father mother : 'person gen_couple =
Obj.magic { parent = [| father; mother |] }
let multi_parent parent : 'person gen_couple = Obj.magic { parent }
type 'a astring = string
type safe_string = [ `encoded | `escaped | `safe ] astring
type escaped_string = [ `encoded | `escaped ] astring
type encoded_string = [ `encoded ] astring
let ( ^^^ ) : 'a astring -> 'a astring -> 'a astring =
fun (a : 'a astring) (b : 'a astring) : 'a astring -> a ^ b
let ( ^>^ ) : 'a astring -> string -> 'a astring =
fun (a : 'a astring) (b : string) : 'a astring -> a ^ b
let ( ^<^ ) : string -> 'a astring -> 'a astring =
fun (a : string) (b : 'a astring) : 'a astring -> a ^ b
let ( <^> ) : 'a astring -> 'a astring -> bool = ( <> )
external safe : string -> safe_string = "%identity"
external escaped : string -> escaped_string = "%identity"
external encoded : string -> encoded_string = "%identity"
external as_string : 'a astring -> string = "%identity"
let safe_fn = ( @@ )

92
lib/def/adef.mli Normal file
View File

@@ -0,0 +1,92 @@
(* $Id: adef.mli,v 5.6 2007-02-21 18:14:01 ddr Exp $ *)
(* Copyright (c) 1998-2007 INRIA *)
type fix
(** Consanguinity rate *)
val float_of_fix : fix -> float
(** Returns float coefficient of consanguinity rate *)
val fix_of_float : float -> fix
(** Returns consanguinity rate from its float coefficient *)
external fix : int -> fix = "%identity"
(** [fix] from int *)
external fix_repr : fix -> int = "%identity"
(** [fix] to int *)
val no_consang : fix
(** No consanguinity *)
(** Date data type that can be either concrete date associated to a calendar or a textual form of the date. *)
type date = Dgreg of dmy * calendar | Dtext of string
(** Supported calendars *)
and calendar = Dgregorian | Djulian | Dfrench | Dhebrew
and dmy = { day : int; month : int; year : int; prec : precision; delta : int }
(** Concrete date with precision. *)
and dmy2 = { day2 : int; month2 : int; year2 : int; delta2 : int }
(** Concrete date without precision. *)
(** Precision attached to the concrete date. *)
and precision =
| Sure
| About
| Maybe
| Before
| After
| OrYear of dmy2
| YearInt of dmy2
(** Compressed date *)
type cdate =
| Cgregorian of int
| Cjulian of int
| Cfrench of int
| Chebrew of int
| Ctext of string
| Cdate of date
| Cnone
type 'person gen_couple
(** Polymorphic type to represent a family's couple.
Couple consists of the father and of the mother. *)
val father : 'a gen_couple -> 'a
(** Get father from couple *)
val mother : 'a gen_couple -> 'a
(** Get mother from couple *)
val couple : 'a -> 'a -> 'a gen_couple
(** [couple f m] creates a couple from father [f] and mother [m] *)
val parent : 'a array -> 'a gen_couple
(** Create [gen_couple] from array. First element of array should be father, second - mother *)
val parent_array : 'a gen_couple -> 'a array
(** Returns array from [gen_couple]. First element of array is father, second - mother *)
val multi_couple : 'a -> 'a -> 'a gen_couple
(** @deprecated Use [couple] instead *)
val multi_parent : 'a array -> 'a gen_couple
(** @deprecated Use [parent] instead *)
type +'a astring = private string
type safe_string = [ `encoded | `escaped | `safe ] astring
type escaped_string = [ `encoded | `escaped ] astring
type encoded_string = [ `encoded ] astring
val ( ^^^ ) : 'a astring -> 'a astring -> 'a astring
val ( ^>^ ) : 'a astring -> string -> 'a astring
val ( ^<^ ) : string -> 'a astring -> 'a astring
val ( <^> ) : 'a astring -> 'a astring -> bool
val safe : string -> safe_string
val escaped : string -> escaped_string
val encoded : string -> encoded_string
val as_string : 'a astring -> string
val safe_fn : (string -> string) -> 'a astring -> 'a astring

458
lib/def/def.ml Normal file
View File

@@ -0,0 +1,458 @@
(* Copyright (c) 1998-2007 INRIA *)
(** Http response status *)
type httpStatus =
| OK (* 200 *)
| Moved_Temporarily (* 302 *)
| Bad_Request (* 400 *)
| Unauthorized (* 401 *)
| Forbidden (* 403 *)
| Not_Found (* 404 *)
| Conflict (* 409 *)
| Internal_Server_Error (* 500 *)
| Service_Unavailable (* 503 *)
exception HttpExn of httpStatus * string
(* TODO OCaml 4.12 : use Either *)
(** Type that represents 2 possible choices *)
type ('a, 'b) choice = Left of 'a | Right of 'b
type cdate = Adef.cdate
(** Alias to [Adef.cdate] *)
(** Alias to [Adef.date] *)
type date = Adef.date =
| Dgreg of dmy * calendar
(* textual form of the date *)
| Dtext of string
(** Alias to [Adef.calendar] *)
and calendar = Adef.calendar = Dgregorian | Djulian | Dfrench | Dhebrew
and dmy = Adef.dmy = {
day : int;
month : int;
year : int;
prec : precision;
delta : int;
}
(** Alias to [Adef.dmy] *)
and dmy2 = Adef.dmy2 = { day2 : int; month2 : int; year2 : int; delta2 : int }
(** Alias to [Adef.dmy2] *)
(** Alias to [Adef.precision] *)
and precision = Adef.precision =
| Sure
| About
| Maybe
| Before
| After
| OrYear of dmy2
(* inteval *)
| YearInt of dmy2
(** Relation kind between couple in the family *)
type relation_kind =
| Married
| NotMarried
| Engaged
| NoSexesCheckNotMarried
| NoMention
| NoSexesCheckMarried
| MarriageBann
| MarriageContract
| MarriageLicense
| Pacs
| Residence
(** Divorce status *)
type divorce = NotDivorced | Divorced of cdate | Separated
(** Death reason *)
type death_reason = Killed | Murdered | Executed | Disappeared | Unspecified
(** Death status *)
type death =
| NotDead
| Death of death_reason * cdate
| DeadYoung
| DeadDontKnowWhen
| DontKnowIfDead
| OfCourseDead
(** Burial information *)
type burial = UnknownBurial | Buried of cdate | Cremated of cdate
(** Rights for access to the personal data *)
type access = IfTitles | Public | Private
(** Title name *)
type 'string gen_title_name = Tmain | Tname of 'string | Tnone
type 'string gen_title = {
t_name : 'string gen_title_name;
t_ident : 'string;
t_place : 'string;
t_date_start : cdate;
t_date_end : cdate;
t_nth : int;
}
(** Type that represents information about nobility title of a person *)
(** Witness kind for an event *)
type witness_kind =
| Witness
| Witness_GodParent
| Witness_CivilOfficer
| Witness_ReligiousOfficer
| Witness_Informant
| Witness_Attending
| Witness_Mentioned
| Witness_Other
(** Personal event name. *)
type 'string gen_pers_event_name =
| Epers_Birth
| Epers_Baptism
| Epers_Death
| Epers_Burial
| Epers_Cremation
| Epers_Accomplishment
| Epers_Acquisition
| Epers_Adhesion
| Epers_BaptismLDS
| Epers_BarMitzvah
| Epers_BatMitzvah
| Epers_Benediction
| Epers_ChangeName
| Epers_Circumcision
| Epers_Confirmation
| Epers_ConfirmationLDS
| Epers_Decoration
| Epers_DemobilisationMilitaire
| Epers_Diploma
| Epers_Distinction
| Epers_Dotation
| Epers_DotationLDS
| Epers_Education
| Epers_Election
| Epers_Emigration
| Epers_Excommunication
| Epers_FamilyLinkLDS
| Epers_FirstCommunion
| Epers_Funeral
| Epers_Graduate
| Epers_Hospitalisation
| Epers_Illness
| Epers_Immigration
| Epers_ListePassenger
| Epers_MilitaryDistinction
| Epers_MilitaryPromotion
| Epers_MilitaryService
| Epers_MobilisationMilitaire
| Epers_Naturalisation
| Epers_Occupation
| Epers_Ordination
| Epers_Property
| Epers_Recensement
| Epers_Residence
| Epers_Retired
| Epers_ScellentChildLDS
| Epers_ScellentParentLDS
| Epers_ScellentSpouseLDS
| Epers_VenteBien
| Epers_Will
| Epers_Name of 'string
type ('person, 'string) gen_pers_event = {
epers_name : 'string gen_pers_event_name;
epers_date : cdate;
epers_place : 'string;
epers_reason : 'string;
epers_note : 'string;
epers_src : 'string;
epers_witnesses : ('person * witness_kind) array;
}
(** Personal event information *)
(** Event name pertaining a family. *)
type 'string gen_fam_event_name =
| Efam_Marriage
| Efam_NoMarriage
| Efam_NoMention
| Efam_Engage
| Efam_Divorce
| Efam_Separated
| Efam_Annulation
| Efam_MarriageBann
| Efam_MarriageContract
| Efam_MarriageLicense
| Efam_PACS
| Efam_Residence
| Efam_Name of 'string
type ('person, 'string) gen_fam_event = {
efam_name : 'string gen_fam_event_name;
efam_date : cdate;
efam_place : 'string;
efam_reason : 'string;
efam_note : 'string;
efam_src : 'string;
efam_witnesses : ('person * witness_kind) array;
}
(** Event information pertaining a family. *)
(** Relation type with parent (if not native) *)
type relation_type =
| Adoption
| Recognition
| CandidateParent
| GodParent
| FosterParent
type ('person, 'string) gen_relation = {
r_type : relation_type;
r_fath : 'person option;
r_moth : 'person option;
r_sources : 'string;
}
(** Relation information with parents (if not native) *)
(** Sex of person *)
type sex = Male | Female | Neuter
type place = {
other : string;
town : string;
township : string;
canton : string;
district : string;
county : string;
region : string;
country : string;
}
(** Place information *)
type ('iper, 'person, 'string) gen_person = {
first_name : 'string;
surname : 'string;
occ : int;
image : 'string;
public_name : 'string;
qualifiers : 'string list;
aliases : 'string list;
first_names_aliases : 'string list;
surnames_aliases : 'string list;
titles : 'string gen_title list;
(* relations with not native parents *)
rparents : ('person, 'string) gen_relation list;
(* related persons like (father of witnessed family,
concerned person of witnessed event, adopted child, etc.) *)
related : 'person list;
occupation : 'string;
sex : sex;
access : access;
birth : cdate;
birth_place : 'string;
birth_note : 'string;
birth_src : 'string;
baptism : cdate;
baptism_place : 'string;
baptism_note : 'string;
baptism_src : 'string;
death : death;
death_place : 'string;
death_note : 'string;
death_src : 'string;
burial : burial;
burial_place : 'string;
burial_note : 'string;
burial_src : 'string;
pevents : ('person, 'string) gen_pers_event list;
notes : 'string;
psources : 'string;
key_index : 'iper;
}
(** Polymorphic type describing information about person. *)
type 'family gen_ascend = { parents : 'family option; consang : Adef.fix }
(** Person's ascendants (family where he is a children) with its consangunity rate
(equal to relationship betwen his parents). *)
(* Person's families to which he belongs as parent (union of families) *)
type 'family gen_union = { family : 'family array }
type 'person gen_descend = { children : 'person array }
(** Children of the family *)
type ('person, 'ifam, 'string) gen_family = {
marriage : cdate;
marriage_place : 'string;
marriage_note : 'string;
marriage_src : 'string;
witnesses : 'person array;
relation : relation_kind;
divorce : divorce;
fevents : ('person, 'string) gen_fam_event list;
comment : 'string;
origin_file : 'string; (* .gw filename where family is defined *)
fsources : 'string;
fam_index : 'ifam;
}
(** Polymorphic type describing information about family. *)
type 'person gen_couple = 'person Adef.gen_couple
(** Alias to [Adef.gen_couple] *)
(** Database errors describing bad specification of the person *)
type 'person error =
| AlreadyDefined of 'person
| OwnAncestor of 'person (** Person is his own ancestor *)
| BadSexOfMarriedPerson of 'person
(** Database warnings attached to the specification of the person, family, relation, etc. *)
type ('iper, 'person, 'family, 'descend, 'title, 'pevent, 'fevent) warning =
| BigAgeBetweenSpouses of
'person
* 'person
* dmy (* Age differece between couples is greater then 50 years *)
| BirthAfterDeath of 'person (** Person is born after his death *)
| IncoherentSex of 'person * int * int (** Incoherent sex of person *)
| ChangedOrderOfChildren of 'family * 'descend * 'iper array * 'iper array
(** Children order has been modified *)
| ChangedOrderOfMarriages of 'person * 'family array * 'family array
(** Person's marriages order has been modified *)
| ChangedOrderOfFamilyEvents of 'family * 'fevent list * 'fevent list
(** Family's events order has been modified *)
| ChangedOrderOfPersonEvents of 'person * 'pevent list * 'pevent list
(** Person's events order has been modified *)
| ChildrenNotInOrder of 'family * 'descend * 'person * 'person
(** Children aren't ordered *)
| CloseChildren of 'family * 'person * 'person
(** Age difference between two child is less then 7 month (except for twins) *)
| DeadOld of 'person * dmy
(** Dead old (at the age older then 109 after 1900 year and older then 100 before) *)
| DeadTooEarlyToBeFather of 'person * 'person
(** Children is born in more then 1 year after his father's death *)
| DistantChildren of 'family * 'person * 'person
(** Age gap between two of siblings greater then 50 years *)
| FEventOrder of 'person * 'fevent * 'fevent
(** Familial events haven't been ordered correctly *)
| FWitnessEventAfterDeath of 'person * 'fevent * 'family
(** Witness is dead before familial event date *)
| FWitnessEventBeforeBirth of 'person * 'fevent * 'family
(** Witness is born after familial event date *)
| IncoherentAncestorDate of 'person * 'person
(** Ancestor is born after person's birth *)
| MarriageDateAfterDeath of 'person (** Person is married after his death *)
| MarriageDateBeforeBirth of 'person
(** Person is married before his birth *)
| MotherDeadBeforeChildBirth of 'person * 'person
(** Children is born after his mother's death *)
| ParentBornAfterChild of 'person * 'person
(** Parent is born after one of his children *)
| ParentTooOld of 'person * dmy * 'person
(** Person became a parent at age older then 55 years for mother and 70 for father *)
| ParentTooYoung of 'person * dmy * 'person
(** Person became a parent at age younger then 11 years old *)
| PEventOrder of 'person * 'pevent * 'pevent
(** Personal events haven't been ordered correctly *)
| PossibleDuplicateFam of 'family * 'family
(** There is a possibility that two families are a duplicate of each other *)
| PossibleDuplicateFamHomonymous of 'family * 'family * 'person
(** There is a possibility that two families are a duplicate of each other (Homonymous spouse) *)
| PWitnessEventAfterDeath of 'person * 'pevent * 'person
(** Witness is dead before personal event date *)
| PWitnessEventBeforeBirth of 'person * 'pevent * 'person
(** Witness is born after personal event date *)
| TitleDatesError of 'person * 'title
(** Title's start date is after end date or person is born after title dates *)
| UndefinedSex of 'person (** Person has undefined sex (Neuter) *)
| YoungForMarriage of 'person * dmy * 'family
(** Person is married before he was 12 years old *)
| OldForMarriage of 'person * dmy * 'family
(** Person is married after he was 100 years old *)
(** Missing sources warning *)
type ('person, 'descend, 'title) misc = MissingSources
(** Database note/page reading mode *)
type rn_mode =
| RnAll (** Read all content *)
| Rn1Ln (** Read first line *)
| RnDeg (** If file isn't empty returns a space *)
type base_notes = {
(* read content of the page with giving mode.
Page "" represent database note *)
nread : string -> rn_mode -> string; (* origin .gw filename *)
norigin_file : string; (* returns list of extended pages *)
efiles : unit -> string list;
}
(** Database note/page explorer structure *)
(** Update modification used for history tracking *)
type ('iper, 'person, 'family, 'string) base_changed =
| U_Add_person of ('iper, 'person, 'string) gen_person
| U_Modify_person of
('iper, 'person, 'string) gen_person
* ('iper, 'person, 'string) gen_person
| U_Delete_person of ('iper, 'person, 'string) gen_person
| U_Merge_person of
('iper, 'person, 'string) gen_person
* ('iper, 'person, 'string) gen_person
* ('iper, 'person, 'string) gen_person
| U_Send_image of ('iper, 'person, 'string) gen_person
| U_Delete_image of ('iper, 'person, 'string) gen_person
| U_Add_family of
('iper, 'person, 'string) gen_person
* ('person, 'family, 'string) gen_family
| U_Modify_family of
('iper, 'person, 'string) gen_person
* ('person, 'family, 'string) gen_family
* ('person, 'family, 'string) gen_family
| U_Delete_family of
('iper, 'person, 'string) gen_person
* ('person, 'family, 'string) gen_family
| U_Invert_family of ('iper, 'person, 'string) gen_person * 'family
| U_Merge_family of
('iper, 'person, 'string) gen_person
* ('person, 'family, 'string) gen_family
* ('person, 'family, 'string) gen_family
* ('person, 'family, 'string) gen_family
| U_Change_children_name of
('iper, 'person, 'string) gen_person
* ((string * string * int * 'person) * (string * string * int * 'person))
list
| U_Add_parent of
('iper, 'person, 'string) gen_person
* ('person, 'family, 'string) gen_family
| U_Kill_ancestors of ('iper, 'person, 'string) gen_person
(* Modification U_Multi used when multiple persons are modified successively. Separation with U_Modify_person is necessary to inform foreign notify_change script
about database change without creating process for every person. *)
| U_Multi of
('iper, 'person, 'string) gen_person
* ('iper, 'person, 'string) gen_person
* bool
| U_Notes of int option * string
(** TODOOCP : doc *)
module NLDB = struct
type ('a, 'b) page =
| PgInd of 'a
| PgFam of 'b
| PgNotes
| PgMisc of string
| PgWizard of string
type key = string * string * int
type ind = { lnTxt : string option; lnPos : int }
type ('a, 'b) t = (('a, 'b) page * (string list * (key * ind) list)) list
end
let ( ^^^ ) = Adef.( ^^^ )
let ( ^>^ ) = Adef.( ^>^ )
let ( ^<^ ) = Adef.( ^<^ )

4
lib/def/dune Normal file
View File

@@ -0,0 +1,4 @@
(library
(name geneweb_def)
(public_name geneweb.def)
(wrapped false))

1882
lib/descendDisplay.ml Normal file
View File

File diff suppressed because it is too large Load Diff

66
lib/descendDisplay.mli Normal file
View File

@@ -0,0 +1,66 @@
(* Public functions for API (plugin v7_descend) *)
val display_descendants_level :
Config.config -> Gwdb.base -> int -> Gwdb.person -> unit
(** Displays only descendants for specified level in unordered lists *)
val display_descendants_with_numbers :
Config.config -> Gwdb.base -> int -> Gwdb.person -> unit
(** Displays descendants with numerated by letter list. Title links to descendats index *)
val display_descendant_index :
Config.config -> Gwdb.base -> int -> Gwdb.person -> unit
(** Displays index of descendants *)
val display_spouse_index :
Config.config -> Gwdb.base -> int -> Gwdb.person -> unit
(** Displays index of descendant's spouses *)
val display_descendant_with_table :
Config.config -> Gwdb.base -> int -> Gwdb.person -> unit
(** Displays descendants in the table where rows are ordered by D'Aboville number. *)
val print_tree : Config.config -> Gwdb.base -> int -> Gwdb.person -> unit
(** Displays tree of descendants *)
val print_aboville : Config.config -> Gwdb.base -> int -> Gwdb.person -> unit
(** Displays descendants as follows :
person
| desc1
| desc2
| | desc21
| desc3
*)
val desmenu_print : Config.config -> Gwdb.base -> Gwdb.person -> unit
(** Prints form that allows to customise display of descendants *)
val print : Config.config -> Gwdb.base -> Gwdb.person -> unit
(** Displays the descendants of the selected in [conv.env] person. Descendants could be displayed by different ways
depending on variable {i t} in [conv.env] environement:
- "L" dispalying descendants in unordered list
- "F" same as "L" but displays only female line
- "M" same as "L" but displays only female line
- "H" table dispalying
- "I" table dispalying with spouses information
- "A" numerated list (d'Aboville)
- "V" displaying a tree of descendants
Previous dispalyings are done by template evaluation. Next ones are done by functions inside this module:
- "B" for [print_aboville]
- "S" for [display_descendants_level]
- "K" for [display_descendant_with_table]
- "N" for [display_descendants_with_numbers]
- "G" for [display_descendant_index]
- "C" for [display_spouse_index]
- "T" for [print_tree]
Variable {i v} is used to select maximal level to descend for descendant displaying (1 for children, 2 for
grandchildren, etc). If {i t} variable isn't defined, then displays the form that allows
customising of display.
*)

174
lib/difference.ml Normal file
View File

@@ -0,0 +1,174 @@
(* $Id: diff.ml,v 5.1 2006-11-03 10:31:18 ddr Exp $ *)
(* Parts of Code of GNU diff (analyze.c) translated from C to OCaml
and adjusted. Basic algorithm described by Eugene W.Myers in:
"An O(ND) Difference Algorithm and Its Variations" *)
exception DiagReturn of int
let diag fd bd sh xv yv xoff xlim yoff ylim =
let dmin = xoff - ylim in
let dmax = xlim - yoff in
let fmid = xoff - yoff in
let bmid = xlim - ylim in
let odd = (fmid - bmid) land 1 <> 0 in
fd.(sh + fmid) <- xoff;
bd.(sh + bmid) <- xlim;
try
let rec loop fmin fmax bmin bmax =
let fmin =
if fmin > dmin then (
fd.(sh + fmin - 2) <- -1;
fmin - 1)
else fmin + 1
in
let fmax =
if fmax < dmax then (
fd.(sh + fmax + 2) <- -1;
fmax + 1)
else fmax - 1
in
(let rec loop d =
if d < fmin then ()
else
let tlo = fd.(sh + d - 1) in
let thi = fd.(sh + d + 1) in
let x = if tlo >= thi then tlo + 1 else thi in
let x =
let rec loop xv yv xlim ylim x y =
if x < xlim && y < ylim && xv x == yv y then
loop xv yv xlim ylim (x + 1) (y + 1)
else x
in
loop xv yv xlim ylim x (x - d)
in
fd.(sh + d) <- x;
if odd && bmin <= d && d <= bmax && bd.(sh + d) <= fd.(sh + d) then
raise (DiagReturn d)
else loop (d - 2)
in
loop fmax);
let bmin =
if bmin > dmin then (
bd.(sh + bmin - 2) <- max_int;
bmin - 1)
else bmin + 1
in
let bmax =
if bmax < dmax then (
bd.(sh + bmax + 2) <- max_int;
bmax + 1)
else bmax - 1
in
(let rec loop d =
if d < bmin then ()
else
let tlo = bd.(sh + d - 1) in
let thi = bd.(sh + d + 1) in
let x = if tlo < thi then tlo else thi - 1 in
let x =
let rec loop xv yv xoff yoff x y =
if x > xoff && y > yoff && xv (x - 1) == yv (y - 1) then
loop xv yv xoff yoff (x - 1) (y - 1)
else x
in
loop xv yv xoff yoff x (x - d)
in
bd.(sh + d) <- x;
if (not odd) && fmin <= d && d <= fmax && bd.(sh + d) <= fd.(sh + d)
then raise (DiagReturn d)
else loop (d - 2)
in
loop bmax);
loop fmin fmax bmin bmax
in
loop fmid fmid bmid bmid
with DiagReturn i -> i
let diff_loop a ai b bi n m =
let fd = Array.make (n + m + 3) 0 in
let bd = Array.make (n + m + 3) 0 in
let sh = m + 1 in
let xvec i = a.(ai.(i)) in
let yvec j = b.(bi.(j)) in
let chng1 = Array.make (Array.length a) true in
let chng2 = Array.make (Array.length b) true in
for i = 0 to n - 1 do
chng1.(ai.(i)) <- false
done;
for j = 0 to m - 1 do
chng2.(bi.(j)) <- false
done;
(let rec loop xoff xlim yoff ylim =
let xoff, yoff =
let rec loop xoff yoff =
if xoff < xlim && yoff < ylim && xvec xoff == yvec yoff then
loop (xoff + 1) (yoff + 1)
else (xoff, yoff)
in
loop xoff yoff
in
let xlim, ylim =
let rec loop xlim ylim =
if xlim > xoff && ylim > yoff && xvec (xlim - 1) == yvec (ylim - 1)
then loop (xlim - 1) (ylim - 1)
else (xlim, ylim)
in
loop xlim ylim
in
if xoff = xlim then
for y = yoff to ylim - 1 do
chng2.(bi.(y)) <- true
done
else if yoff = ylim then
for x = xoff to xlim - 1 do
chng1.(ai.(x)) <- true
done
else
let d = diag fd bd sh xvec yvec xoff xlim yoff ylim in
let b = bd.(sh + d) in
loop xoff b yoff (b - d);
loop b xlim (b - d) ylim
in
loop 0 n 0 m);
(chng1, chng2)
(* [make_indexer a b] returns an array of index of items of [a] which
are also present in [b]; this way, the main algorithm can skip items
which, anyway, are different. This improves the speed much.
The same time, this function updates the items of so that all
equal items point to the same unique item. All items comparisons in
the main algorithm can therefore be done with [==] instead of [=],
what can improve speed much. *)
let make_indexer a b =
let n = Array.length a in
let htb = Hashtbl.create (10 * Array.length b) in
Array.iteri
(fun i e ->
try b.(i) <- Hashtbl.find htb e with Not_found -> Hashtbl.add htb e e)
b;
let ai = Array.make n 0 in
let k =
let rec loop i k =
if i = n then k
else
let k =
try
a.(i) <- Hashtbl.find htb a.(i);
(* line found (since "Not_found" not raised) *)
ai.(k) <- i;
k + 1
with Not_found -> k
in
loop (i + 1) k
in
loop 0 0
in
Array.sub ai 0 k
let f a b =
let ai = make_indexer a b in
let bi = make_indexer b a in
let n = Array.length ai in
let m = Array.length bi in
diff_loop a ai b bi n m

18
lib/difference.mli Normal file
View File

@@ -0,0 +1,18 @@
(* $Id: diff.mli,v 5.1 2006-11-03 10:31:18 ddr Exp $ *)
(** Differences between two arrays. *)
val f : 'a array -> 'a array -> bool array * bool array
(** [Difference.f a1 a2] returns a couple of two arrays of booleans [(d1, d2)].
[d1] has the same size as [a1].
[d2] has the same size as [a2].
[d1.(i)] is [True] if [a1.(i)] has no corresponding value in [a2].
[d2.(i)] is [True] if [a2.(i)] has no corresponding value in [a1].
[d1] and [s2] have the same number of values equal to [False].
Can be used to write the [diff] program (comparison of two files),
the input arrays being the array of lines of each file.
Can be used also to compare two strings (they must have been exploded
into arrays of chars), or two DNA strings, and so on.
*)

23
lib/dune.in Normal file
View File

@@ -0,0 +1,23 @@
(dirs :standard \ %%%DUNE_DIRS_EXCLUDE%%%)
(ocamllex (modules templ_parser))
(library
(name geneweb)
(public_name geneweb)
(synopsis "GeneWeb library")
(preprocess (action (run %{bin:cppo} %%%CPPO_D%%% -V OCAML:%{ocaml_version} %{input-file})))
(libraries unix
str
stdlib-shims
camlp-streams
geneweb_core
geneweb_def
geneweb_gwdb
geneweb_sosa_mli
geneweb_util
markup
uri
wserver)
(modules_without_implementation templAst)
)

107
lib/event.ml Normal file
View File

@@ -0,0 +1,107 @@
open Def
open Gwdb
type 'a event_name =
| Pevent of 'a gen_pers_event_name
| Fevent of 'a gen_fam_event_name
(*
On ignore les événements personnalisés.
Dans l'ordre de priorité :
birth, baptism, ..., death, funeral, burial/cremation.
Pour les évènements familiaux, cet ordre est envisageable :
engage, PACS, marriage bann, marriage contract, marriage, ...,
separate, divorce
*)
let compare_event_name name1 name2 =
match (name1, name2) with
| Pevent Epers_Birth, _ -> -1
| _, Pevent Epers_Birth -> 1
| ( Pevent Epers_Baptism,
Pevent (Epers_Death | Epers_Funeral | Epers_Burial | Epers_Cremation) ) ->
-1
| ( Pevent (Epers_Death | Epers_Funeral | Epers_Burial | Epers_Cremation),
Pevent Epers_Baptism ) ->
1
| Pevent Epers_Cremation, Pevent Epers_Burial -> -1
| Pevent (Epers_Burial | Epers_Cremation), _ -> 1
| _, Pevent (Epers_Burial | Epers_Cremation) -> -1
| Pevent Epers_Funeral, _ -> 1
| _, Pevent Epers_Funeral -> -1
| Pevent Epers_Death, _ -> 1
| _, Pevent Epers_Death -> -1
| _ -> 0
(*TODO Fevent??*)
let compare get_name get_date e1 e2 =
match Date.cdate_to_dmy_opt (get_date e1) with
| None -> compare_event_name (get_name e1) (get_name e2)
| Some d1 -> (
match Date.cdate_to_dmy_opt (get_date e2) with
| None -> compare_event_name (get_name e1) (get_name e2)
| Some d2 -> (
match Date.compare_dmy_opt ~strict:false d1 d2 with
| Some 0 | None -> compare_event_name (get_name e1) (get_name e2)
| Some x -> x))
let sort_events get_name get_date events =
List.stable_sort (fun e1 e2 -> compare get_name get_date e1 e2) events
type 'a event_item =
'a event_name
* cdate
* istr
* istr
* istr
* (iper * witness_kind) array
* iper option
let events conf base p =
if not (Util.authorized_age conf base p) then []
else
let pevents =
List.fold_right
(fun evt events ->
let name = Pevent evt.epers_name in
let date = evt.epers_date in
let place = evt.epers_place in
let note = evt.epers_note in
let src = evt.epers_src in
let wl = evt.epers_witnesses in
let x = (name, date, place, note, src, wl, None) in
x :: events)
(get_pevents p) []
in
let fevents =
Array.fold_right
(fun ifam fevents ->
let fam = foi base ifam in
let isp = Gutil.spouse (get_iper p) fam in
let m_auth =
Util.authorized_age conf base (Util.pget conf base isp)
in
let fam_fevents =
if m_auth then
List.fold_right
(fun evt fam_fevents ->
let name = Fevent evt.efam_name in
let date = evt.efam_date in
let place = evt.efam_place in
let note = evt.efam_note in
let src = evt.efam_src in
let wl = evt.efam_witnesses in
let x = (name, date, place, note, src, wl, Some isp) in
x :: fam_fevents)
(get_fevents fam) []
else []
in
fam_fevents @ fevents)
(get_family p) []
in
pevents @ fevents
let sorted_events conf base p =
let unsorted_events = events conf base p in
let get_name (n, _, _, _, _, _, _) = n in
let get_date (_, date, _, _, _, _, _) = date in
sort_events get_name get_date unsorted_events

29
lib/event.mli Normal file
View File

@@ -0,0 +1,29 @@
open Gwdb
(* NOTE : checkItem defined this as 'string event_same, instead of just istr
.. why make it complicated *)
type 'a event_name =
| Pevent of 'a Def.gen_pers_event_name
| Fevent of 'a Def.gen_fam_event_name
type 'a event_item =
'a event_name
* Def.cdate
* istr
* istr
* istr
* (iper * Def.witness_kind) array
* iper option
(** a representation of events *)
val compare_event_name : 'a event_name -> 'a event_name -> int
val sort_events :
('a -> 'b event_name) -> ('a -> Adef.cdate) -> 'a list -> 'a list
(** Sort events (both personal and familial) by their date and their name *)
val events : Config.config -> base -> person -> istr event_item list
(** [events conf base p] is the list of [p]'s events *)
val sorted_events : Config.config -> base -> person -> istr event_item list
(** [sorted_events conf base p] is the list of [p]'s events, sorted by Checkitem.sorted_events *)

488
lib/fixbase.ml Normal file
View File

@@ -0,0 +1,488 @@
open Def
open Gwdb
type patch =
| Fix_NBDS of iper
| Fix_AddedUnion of iper
| Fix_AddedParents of iper
| Fix_ParentDeleted of iper
| Fix_AddedChild of ifam
| Fix_RemovedUnion of iper * ifam
| Fix_RemovedDuplicateUnion of iper * ifam
| Fix_AddedRelatedFromPevent of iper * iper
| Fix_AddedRelatedFromFevent of iper * iper
| Fix_MarriageDivorce of ifam
| Fix_MissingSpouse of ifam * iper
| Fix_WrongUTF8Encoding of
Gwdb.ifam option * Gwdb.iper option * (Gwdb.istr * Gwdb.istr) option
| Fix_UpdatedOcc of iper * int * int
let mk_pevent name date place note src =
{
epers_name = name;
epers_date = date;
epers_place = place;
epers_reason = empty_string;
epers_note = note;
epers_src = src;
epers_witnesses = [||];
}
let of_pevent e = (e.epers_date, e.epers_place, e.epers_note, e.epers_src)
let find_pevent names pevents =
List.find_opt (fun x -> List.mem x.epers_name names) pevents
let fix_pevents ?report base pp =
(* Should it use UpdateIndOk.reconstitute_from_pevents? *)
(* TODO clean up *)
let p = gen_person_of_person pp in
let empty_bi =
(Date.cdate_None, Gwdb.empty_string, Gwdb.empty_string, Gwdb.empty_string)
in
let empty_bp =
(Date.cdate_None, Gwdb.empty_string, Gwdb.empty_string, Gwdb.empty_string)
in
let empty_de =
(Date.cdate_None, Gwdb.empty_string, Gwdb.empty_string, Gwdb.empty_string)
in
let empty_bu =
(Date.cdate_None, Gwdb.empty_string, Gwdb.empty_string, Gwdb.empty_string)
in
let pevents = p.pevents in
let aux name date place note src empty pevents =
match find_pevent [ name ] pevents with
| None ->
let pevents =
if (date, place, note, src) <> empty then
mk_pevent name date place note src :: pevents
else pevents
in
((date, place, note, src), pevents)
| Some e ->
let e' =
{
epers_name = e.epers_name;
epers_date =
(if e.epers_date = Date.cdate_None then date else e.epers_date);
epers_place =
(if e.epers_place = Gwdb.empty_string then place
else e.epers_place);
epers_reason = e.epers_reason;
epers_note =
(if e.epers_note = Gwdb.empty_string then note else e.epers_note);
epers_src =
(if e.epers_src = Gwdb.empty_string then src else e.epers_src);
epers_witnesses = e.epers_witnesses;
}
in
(of_pevent e', Mutil.list_replace e e' pevents)
in
let (birth, birth_place, birth_note, birth_src), pevents =
aux Epers_Birth p.birth p.birth_place p.birth_note p.birth_src empty_bi
pevents
in
let (baptism, baptism_place, baptism_note, baptism_src), pevents =
aux Epers_Baptism p.baptism p.baptism_place p.baptism_note p.baptism_src
empty_bp pevents
in
let (death, death_place, death_note, death_src), pevents =
let death =
match p.death with
| Death (_, d) -> d
| NotDead | DeadYoung | DeadDontKnowWhen | DontKnowIfDead | OfCourseDead
->
Date.cdate_None
in
aux Epers_Death death p.death_place p.death_note p.death_src empty_de
pevents
in
let death =
match p.death with
| Death _ -> p.death
| NotDead when death <> Date.cdate_None -> Death (Unspecified, death)
| x -> x
in
let (burial, burial_place, burial_note, burial_src), pevents =
match p.burial with
| UnknownBurial -> (
match find_pevent [ Epers_Burial; Epers_Cremation ] pevents with
| None ->
( (UnknownBurial, p.burial_place, p.burial_note, p.burial_src),
pevents )
| Some e ->
let bu, bu_place, bu_note, bu_src = of_pevent e in
( ( (match e.epers_name with
| Epers_Burial -> Buried bu
| Epers_Cremation -> Cremated bu
| _ -> assert false),
bu_place,
bu_note,
bu_src ),
pevents ))
| Buried d ->
let (d, bu_place, bu_note, bu_src), pevents =
aux Epers_Burial d p.burial_place p.burial_note p.burial_src empty_bu
pevents
in
((Buried d, bu_place, bu_note, bu_src), pevents)
| Cremated d ->
let (d, bu_place, bu_note, bu_src), pevents =
aux Epers_Cremation d p.burial_place p.burial_note p.burial_src
empty_bu pevents
in
((Cremated d, bu_place, bu_note, bu_src), pevents)
in
let p' =
{
p with
birth;
birth_place;
birth_note;
birth_src;
baptism;
baptism_place;
baptism_note;
baptism_src;
death;
death_place;
death_note;
death_src;
burial;
burial_place;
burial_note;
burial_src;
pevents;
}
in
if p <> p' then (
patch_person base p.key_index p';
match report with Some fn -> fn (Fix_NBDS p.key_index) | None -> ())
let check_NBDS ?report progress base =
let nb_ind = nb_of_persons base in
Gwdb.Collection.iteri
(fun i p ->
progress i nb_ind;
fix_pevents ?report base p)
(Gwdb.persons base)
let check_families_parents ?report progress base =
let nb_fam = nb_of_families base in
Gwdb.Collection.iteri
(fun i fam ->
progress i nb_fam;
let ifam = get_ifam fam in
Array.iter
(fun ip ->
let unions = get_family (poi base ip) in
if not @@ Array.mem ifam unions then (
patch_union base ip { family = Array.append unions [| ifam |] };
match report with Some fn -> fn (Fix_AddedUnion ip) | None -> ()))
(get_parent_array fam))
(Gwdb.families base)
let check_families_children ?report progress base =
let nb_fam = nb_of_families base in
Gwdb.Collection.iteri
(fun i fam ->
let ifam = get_ifam fam in
progress i nb_fam;
let children = get_children fam in
for j = 0 to Array.length children - 1 do
let ip = children.(j) in
let a = poi base ip in
let parents = get_parents a in
if parents = Some dummy_ifam || parents = None then (
patch_ascend base ip { parents = Some ifam; consang = get_consang a };
match report with Some fn -> fn (Fix_AddedParents ip) | None -> ())
(* else if parents <> Some ifam && verbosity1 then begin
* (\* FIXME: what to do here ? *\)
* Printf.printf "\tbad parents : %s\n" (string_of_p base ip);
* flush stdout
* end *)
done)
(Gwdb.families base)
let check_persons_parents ?report progress base =
let nb_ind = nb_of_persons base in
Gwdb.Collection.iteri
(fun i p ->
progress i nb_ind;
get_parents p
|> Option.iter @@ fun ifam ->
let ip = get_iper p in
let fam = Gwdb.foi base ifam in
if get_ifam fam = dummy_ifam then (
patch_ascend base ip { parents = None; consang = Adef.no_consang };
match report with Some fn -> fn (Fix_ParentDeleted ip) | None -> ())
else
let children = get_children fam in
if not @@ Array.mem ip children then (
let children = Array.append children [| ip |] in
patch_descend base ifam { children };
match report with
| Some fn -> fn (Fix_AddedChild ifam)
| None -> ()))
(Gwdb.persons base)
let check_persons_families ?report progress base =
let nb_ind = nb_of_persons base in
Gwdb.Collection.iteri
(fun i p ->
progress i nb_ind;
let ip = get_iper p in
let ifams = get_family p in
let ifams' =
Array.of_list
@@ Array.fold_right
(fun ifam acc ->
let cpl = foi base ifam in
if List.mem ifam acc then
match report with
| Some fn ->
fn (Fix_RemovedDuplicateUnion (ip, ifam));
acc
| None -> acc
else if not @@ Array.mem ip (get_parent_array cpl) then
match report with
| Some fn ->
fn (Fix_RemovedUnion (ip, ifam));
acc
| None -> acc
else ifam :: acc)
ifams []
in
if ifams' <> ifams then patch_union base ip { family = ifams' })
(Gwdb.persons base)
let check_pevents_witnesses ?report progress base =
let nb_ind = nb_of_persons base in
Gwdb.Collection.iteri
(fun i p ->
progress i nb_ind;
let ip = get_iper p in
List.iter
(fun evt ->
let witn = Array.map fst evt.epers_witnesses in
for j = 0 to Array.length witn - 1 do
let ip2 = witn.(j) in
let p2 = poi base ip2 in
if not (List.memq ip (get_related p2)) then (
patch_person base ip2
{
(gen_person_of_person p2) with
related = ip :: get_related p2;
};
match report with
| Some fn -> fn (Fix_AddedRelatedFromPevent (ip2, ip))
| None -> ())
done)
(get_pevents p))
(Gwdb.persons base)
let check_fevents_witnesses ?report progress base =
let nb_fam = nb_of_families base in
Gwdb.Collection.iteri
(fun i fam ->
progress i nb_fam;
let ifath = get_father fam in
List.iter
(fun evt ->
let witn = Array.map fst evt.efam_witnesses in
for j = 0 to Array.length witn - 1 do
let ip = witn.(j) in
let p = poi base ip in
if not (List.memq ifath (get_related p)) then (
patch_person base ip
{
(gen_person_of_person p) with
related = ifath :: get_related p;
};
match report with
| Some fn -> fn (Fix_AddedRelatedFromFevent (ip, ifath))
| None -> ())
done)
(get_fevents fam))
(Gwdb.families base)
let fix_marriage_divorce ?report progress base =
let nb_fam = nb_of_families base in
Gwdb.Collection.iteri
(fun i fam ->
progress i nb_fam;
let fevents = get_fevents fam in
let relation0 = get_relation fam in
let marriage0 = get_marriage fam in
let marriage_place0 = get_marriage_place fam in
let marriage_note0 = get_marriage_note fam in
let marriage_src0 = get_marriage_src fam in
let divorce0 = get_divorce fam in
let marr_data0 =
(relation0, marriage0, marriage_place0, marriage_note0, marriage_src0)
in
let ( ((relation, marriage, marriage_place, marriage_note, marriage_src)
as marr_data),
divorce,
_ ) =
UpdateFamOk.reconstitute_from_fevents false (insert_string base "")
fevents
in
if marr_data0 <> marr_data || divorce0 <> divorce then (
let fam' =
{
(gen_family_of_family fam) with
relation;
marriage;
marriage_place;
marriage_note;
marriage_src;
divorce;
}
in
patch_family base (get_ifam fam) fam';
match report with
| Some fn -> fn (Fix_MarriageDivorce (get_ifam fam))
| None -> ()))
(Gwdb.families base)
let fix_missing_spouses ?report progress base =
let nb_fam = nb_of_families base in
Gwdb.Collection.iteri
(fun i fam ->
progress i nb_fam;
let aux i =
let p = poi base i in
if get_iper p = Gwdb.dummy_iper then (
Gwdb.patch_union base i { family = [| get_ifam fam |] };
Gwdb.patch_person base i
{ (gen_person_of_person p) with key_index = i };
match report with
| Some fn -> fn (Fix_MissingSpouse (get_ifam fam, i))
| None -> ())
in
aux @@ get_father fam;
aux @@ get_mother fam)
(Gwdb.families base)
let fix_utf8_sequence ?report progress base =
let normalize_utf_8_date ifam iper s =
let s' = Mutil.normalize_utf_8 s in
(if s <> s' then
match report with
| Some fn -> fn (Fix_WrongUTF8Encoding (ifam, iper, None))
| None -> ());
s'
in
let normalize_utf_8 ifam iper i =
let s = Gwdb.sou base i in
let s' = Mutil.normalize_utf_8 s in
let i' = Gwdb.insert_string base s' in
(if i <> i' then
match report with
| Some fn -> fn (Fix_WrongUTF8Encoding (ifam, iper, Some (i, i')))
| None -> ());
i'
in
let nbf = nb_of_families base in
let nbp = nb_of_persons base in
let nb = nbp + nbf in
let fp i = i in
let ff i = i in
let fs ifam iper i = normalize_utf_8 ifam iper i in
let fd ifam iper = function
| Dtext d -> Dtext (normalize_utf_8_date ifam iper d)
| d -> d
in
Gwdb.Collection.iteri
(fun i fam ->
progress i nb;
let ifam = Gwdb.get_ifam fam in
let f = Gwdb.gen_family_of_family fam in
let f' =
Futil.map_family_ps ~fd:(fd (Some ifam) None) fp ff
(fs (Some ifam) None) f
in
if f' <> f then Gwdb.patch_family base ifam f')
(Gwdb.families base);
Gwdb.Collection.iteri
(fun i per ->
progress (nbf + i) nb;
let iper = Gwdb.get_iper per in
let p = Gwdb.gen_person_of_person per in
let p' =
Futil.map_person_ps ~fd:(fd None (Some iper)) fp (fs None (Some iper)) p
in
if p' <> p then Gwdb.patch_person base iper p')
(Gwdb.persons base)
let fix_key ?report progress base =
let nb_ind = nb_of_persons base in
let ipers = Gwdb.ipers base in
let skip = Gwdb.iper_marker ipers false in
Gwdb.Collection.iteri
(fun i ip ->
progress i nb_ind;
let p = poi base ip in
let f = Gwdb.p_first_name base p in
let s = Gwdb.p_surname base p in
if f <> "?" && s <> "?" then
let key = Name.concat f s in
let ipers = Gwdb.persons_of_name base key in
let f = Name.lower f in
let s = Name.lower s in
let list =
let rec loop acc = function
| ip :: tl ->
let p = poi base ip in
if
Name.lower @@ p_first_name base p = f
&& Name.lower @@ p_surname base p = s
then loop ((get_iper p, get_occ p) :: acc) tl
else loop acc tl
| [] -> acc
in
loop [] ipers
in
let rev_list = List.sort (fun a b -> compare b a) list in
let cnt = ref 0 in
let mem_occ occ acc list =
List.exists (fun (_, o) -> o = occ) acc
|| List.exists (fun (_, o) -> o = occ) list
in
let rec new_occ acc list =
if mem_occ !cnt acc list then (
incr cnt;
new_occ acc list)
else !cnt
in
let rec loop acc list =
match acc with
| [] -> (
match list with
| [] -> failwith key
| (ip, occ) :: tl ->
Gwdb.Marker.set skip ip true;
loop [ (ip, occ) ] tl)
| acc -> (
match list with
| [] -> acc
| (ip, occ) :: tl ->
if not @@ Gwdb.Marker.get skip ip then (
Gwdb.Marker.set skip ip true;
if mem_occ occ acc tl then (
let occ' = new_occ acc list in
Gwdb.patch_person base ip
{
(Gwdb.gen_person_of_person (poi base ip)) with
occ = occ';
};
(match report with
| Some fn -> fn (Fix_UpdatedOcc (ip, occ, occ'))
| None -> ());
loop ((ip, occ') :: acc) tl)
else loop ((ip, occ) :: acc) tl)
else loop ((ip, occ) :: acc) tl)
in
ignore @@ loop [] rev_list)
ipers

83
lib/fixbase.mli Normal file
View File

@@ -0,0 +1,83 @@
(** All the function of this module scan the base and fix what is considered as corrupted data.
They all share a same signature : [let check_XXX ?report progress base = ...]
The optionnal [report] function should be used to track changes.
[progress i max] keep tracks of the progress of a task. When called, task is
about [i/max] done.
Note that it does not actually commit the changes, so if you do not want a dry run, apply
[Gwdb.commit_patches]
*)
(** All possible patches that could be automatically deducted from inconsistent
or absent information in the database *)
type patch =
| Fix_NBDS of Gwdb.iper
| Fix_AddedUnion of Gwdb.iper
| Fix_AddedParents of Gwdb.iper
| Fix_ParentDeleted of Gwdb.iper
| Fix_AddedChild of Gwdb.ifam
| Fix_RemovedUnion of Gwdb.iper * Gwdb.ifam
| Fix_RemovedDuplicateUnion of Gwdb.iper * Gwdb.ifam
| Fix_AddedRelatedFromPevent of Gwdb.iper * Gwdb.iper
| Fix_AddedRelatedFromFevent of Gwdb.iper * Gwdb.iper
| Fix_MarriageDivorce of Gwdb.ifam
| Fix_MissingSpouse of Gwdb.ifam * Gwdb.iper
| Fix_WrongUTF8Encoding of
Gwdb.ifam option * Gwdb.iper option * (Gwdb.istr * Gwdb.istr) option
| Fix_UpdatedOcc of Gwdb.iper * int * int
val check_NBDS :
?report:(patch -> unit) -> (int -> int -> unit) -> Gwdb.base -> unit
(** For every person in the base synchronise his birth, death, baptism and burial events with
his fields and vice versa. *)
val check_families_parents :
?report:(patch -> unit) -> (int -> int -> unit) -> Gwdb.base -> unit
(** For every family's parent in the base add current family to the parent's union if absent. *)
val check_families_children :
?report:(patch -> unit) -> (int -> int -> unit) -> Gwdb.base -> unit
(** For every family's children in the base add current family to the children's ascendants if absent.
Doesn't modify consanguinity rate. *)
val check_persons_parents :
?report:(patch -> unit) -> (int -> int -> unit) -> Gwdb.base -> unit
(** For every person checks their ascendants.
If it references to the dummy family, then remove this reference.
Otherwise add the person to the family's children if absent. *)
val check_persons_families :
?report:(patch -> unit) -> (int -> int -> unit) -> Gwdb.base -> unit
(** For every person in the base removes all duplicate families and families where person isn't a parent. *)
val check_pevents_witnesses :
?report:(patch -> unit) -> (int -> int -> unit) -> Gwdb.base -> unit
(** For every person's event's witness add current person to the list of related of the witness if absent. *)
val check_fevents_witnesses :
?report:(patch -> unit) -> (int -> int -> unit) -> Gwdb.base -> unit
(** For every family's event's witness add family's father to the list of related of the witness if absent. *)
val fix_marriage_divorce :
?report:(patch -> unit) -> (int -> int -> unit) -> Gwdb.base -> unit
(** For every family in the base synchronise its fields with marriage and divorce events. *)
val fix_missing_spouses :
?report:(patch -> unit) -> (int -> int -> unit) -> Gwdb.base -> unit
(** For every family, if a parent refers to a person dummy person (with dummy iper).
Fix this person and add the family to their union list.
If this situation happens, an explaination is that the person has been incorrectly deleted,
instead of just erasing their personal details.
*)
val fix_utf8_sequence :
?report:(patch -> unit) -> (int -> int -> unit) -> Gwdb.base -> unit
(** For every person's and family's field, remplace it with normalized UTF8 version. *)
val fix_key :
?report:(patch -> unit) -> (int -> int -> unit) -> Gwdb.base -> unit
(** For every person in the base, update their occurence number
if someone with same key (normalized first name and last name, and occurence number) already exists. *)

112
lib/gwdb-legacy/btree.ml Normal file
View File

@@ -0,0 +1,112 @@
(* This code is directly copied from OCaml stdlib (Map module)
with t*)
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
module type OrderedType = sig
type t
val compare : t -> t -> int
end
module type S = sig
type key
type +'a t
val mem : key -> 'a t -> bool
val add : key -> 'a -> 'a t -> 'a t
val find : key -> 'a t -> 'a
(* Added for GeneWeb *)
val key_after : (key -> int) -> 'a t -> key
val next : key -> 'a t -> key
end
module Make (Ord : OrderedType) : S with type key = Ord.t = struct
type key = Ord.t
type 'a t = Empty | Node of { l : 'a t; v : key; d : 'a; r : 'a t; h : int }
let height = function Empty -> 0 | Node { h } -> h
let create l x d r =
let hl = height l and hr = height r in
Node { l; v = x; d; r; h = (if hl >= hr then hl + 1 else hr + 1) }
let bal l x d r =
let hl = match l with Empty -> 0 | Node { h } -> h in
let hr = match r with Empty -> 0 | Node { h } -> h in
if hl > hr + 2 then
match l with
| Empty -> invalid_arg "Map.bal"
| Node { l = ll; v = lv; d = ld; r = lr } -> (
if height ll >= height lr then create ll lv ld (create lr x d r)
else
match lr with
| Empty -> invalid_arg "Map.bal"
| Node { l = lrl; v = lrv; d = lrd; r = lrr } ->
create (create ll lv ld lrl) lrv lrd (create lrr x d r))
else if hr > hl + 2 then
match r with
| Empty -> invalid_arg "Map.bal"
| Node { l = rl; v = rv; d = rd; r = rr } -> (
if height rr >= height rl then create (create l x d rl) rv rd rr
else
match rl with
| Empty -> invalid_arg "Map.bal"
| Node { l = rll; v = rlv; d = rld; r = rlr } ->
create (create l x d rll) rlv rld (create rlr rv rd rr))
else Node { l; v = x; d; r; h = (if hl >= hr then hl + 1 else hr + 1) }
let rec add x data = function
| Empty -> Node { l = Empty; v = x; d = data; r = Empty; h = 1 }
| Node { l; v; d; r; h } as m ->
let c = Ord.compare x v in
if c = 0 then if d == data then m else Node { l; v = x; d = data; r; h }
else if c < 0 then
let ll = add x data l in
if l == ll then m else bal ll v d r
else
let rr = add x data r in
if r == rr then m else bal l v d rr
let rec find x = function
| Empty -> raise Not_found
| Node { l; v; d; r } ->
let c = Ord.compare x v in
if c = 0 then d else find x (if c < 0 then l else r)
let rec mem x = function
| Empty -> false
| Node { l; v; r } ->
let c = Ord.compare x v in
c = 0 || mem x (if c < 0 then l else r)
(* Added for GeneWeb *)
let rec key_after f_compare = function
| Empty -> raise Not_found
| Node { l; v; r; _ } ->
let c = f_compare v in
if c < 0 then try key_after f_compare l with Not_found -> v
else if c > 0 then key_after f_compare r
else v
let rec next x = function
| Empty -> raise Not_found
| Node { l; v; r; _ } ->
let c = Ord.compare x v in
if c < 0 then try next x l with Not_found -> v else next x r
end

35
lib/gwdb-legacy/btree.mli Normal file
View File

@@ -0,0 +1,35 @@
(** Input signature of the functor [Btree.Make]. *)
module type OrderedType = sig
type t
val compare : t -> t -> int
end
(** Output signature of the functor [Btree.Make]. *)
module type S = sig
type key
(** Same as {!Stdlib.Map.S.key} *)
type +'a t
(** Same as {!Stdlib.Map.S.t} *)
val mem : key -> 'a t -> bool
(** Same as {!Stdlib.Map.S.mem} *)
val add : key -> 'a -> 'a t -> 'a t
(** Same as {!Stdlib.Map.S.add} *)
val find : key -> 'a t -> 'a
(** Same as {!Stdlib.Map.S.find} *)
val key_after : (key -> int) -> 'a t -> key
(** [key_after f_compare m] browse map [m] to find the key [k] which
gives [f_compare k = 0]. Raise [Not_found] if such key doesn't exists. *)
val next : key -> 'a t -> key
(** [next k bt] returns the smallest key that is bigger then [k] inside [bt]. *)
end
(** Functor building an implementation of the map structure given a
totally ordered type. *)
module Make : functor (Ord : OrderedType) -> S with type key = Ord.t

1288
lib/gwdb-legacy/database.ml Normal file
View File

File diff suppressed because it is too large Load Diff

35
lib/gwdb-legacy/database.mli Normal file
View File

@@ -0,0 +1,35 @@
(* Copyright (c) 1998-2007 INRIA *)
val opendb : string -> Dbdisk.dsk_base
(** Initialise [dsk_base] from the database situated in the specified directory.
Initialises both data and functionallity part. *)
val make :
string ->
string list ->
((int, int, int) Def.gen_person array
* int Def.gen_ascend array
* int Def.gen_union array)
* ((int, int, int) Def.gen_family array
* int Def.gen_couple array
* int Def.gen_descend array)
* string array
* Def.base_notes ->
Dbdisk.dsk_base
(** [make bname particles ((persons, ascendants, unions) (families, couples,
descendants) strings base_notes)] returns initialised with giving data
[dsk_base]. This function is called exclusively for database creating
purpose. It means that, it contains only data without functionalities.
Either call [opendb] on existing database or call [Gwdb.make], if you
want to make requests. *)
(* Ajout pour l'API *)
type synchro_patch = {
mutable synch_list : (string * int list * int list) list;
}
(** List of commited modifications inside the database. First element is a timestamp of a commit,
second - changed/added by considered commit person ids, third - changed/added by considered commit families ids. *)
val input_synchro : string -> synchro_patch
(** Get [synchro_patch] from the giving database directory. *)

429
lib/gwdb-legacy/dbdisk.mli Normal file
View File

@@ -0,0 +1,429 @@
(** {1 Aliases to [Def] and [Adef]} *)
type fix = Adef.fix (* FIXME: expose its type *)
type cdate = Def.cdate (* FIXME: expose its type *)
type date = Def.date = Dgreg of dmy * calendar | Dtext of string
and calendar = Def.calendar = Dgregorian | Djulian | Dfrench | Dhebrew
and dmy = Def.dmy = {
day : int;
month : int;
year : int;
prec : precision;
delta : int;
}
and dmy2 = Def.dmy2 = { day2 : int; month2 : int; year2 : int; delta2 : int }
and precision = Def.precision =
| Sure
| About
| Maybe
| Before
| After
| OrYear of dmy2
| YearInt of dmy2
type relation_kind = Def.relation_kind =
| Married
| NotMarried
| Engaged
| NoSexesCheckNotMarried
| NoMention
| NoSexesCheckMarried
| MarriageBann
| MarriageContract
| MarriageLicense
| Pacs
| Residence
type divorce = Def.divorce = NotDivorced | Divorced of cdate | Separated
type death_reason = Def.death_reason =
| Killed
| Murdered
| Executed
| Disappeared
| Unspecified
type death = Def.death =
| NotDead
| Death of death_reason * cdate
| DeadYoung
| DeadDontKnowWhen
| DontKnowIfDead
| OfCourseDead
type burial = Def.burial = UnknownBurial | Buried of cdate | Cremated of cdate
type access = Def.access = IfTitles | Public | Private
type 'string gen_title_name = 'string Def.gen_title_name =
| Tmain
| Tname of 'string
| Tnone
type 'string gen_title = 'string Def.gen_title = {
t_name : 'string gen_title_name;
t_ident : 'string;
t_place : 'string;
t_date_start : cdate;
t_date_end : cdate;
t_nth : int;
}
type witness_kind = Def.witness_kind =
| Witness
| Witness_GodParent
| Witness_CivilOfficer
| Witness_ReligiousOfficer
| Witness_Informant
| Witness_Attending
| Witness_Mentioned
| Witness_Other
type 'string gen_pers_event_name = 'string Def.gen_pers_event_name =
| Epers_Birth
| Epers_Baptism
| Epers_Death
| Epers_Burial
| Epers_Cremation
| Epers_Accomplishment
| Epers_Acquisition
| Epers_Adhesion
| Epers_BaptismLDS
| Epers_BarMitzvah
| Epers_BatMitzvah
| Epers_Benediction
| Epers_ChangeName
| Epers_Circumcision
| Epers_Confirmation
| Epers_ConfirmationLDS
| Epers_Decoration
| Epers_DemobilisationMilitaire
| Epers_Diploma
| Epers_Distinction
| Epers_Dotation
| Epers_DotationLDS
| Epers_Education
| Epers_Election
| Epers_Emigration
| Epers_Excommunication
| Epers_FamilyLinkLDS
| Epers_FirstCommunion
| Epers_Funeral
| Epers_Graduate
| Epers_Hospitalisation
| Epers_Illness
| Epers_Immigration
| Epers_ListePassenger
| Epers_MilitaryDistinction
| Epers_MilitaryPromotion
| Epers_MilitaryService
| Epers_MobilisationMilitaire
| Epers_Naturalisation
| Epers_Occupation
| Epers_Ordination
| Epers_Property
| Epers_Recensement
| Epers_Residence
| Epers_Retired
| Epers_ScellentChildLDS
| Epers_ScellentParentLDS
| Epers_ScellentSpouseLDS
| Epers_VenteBien
| Epers_Will
| Epers_Name of 'string
type ('person, 'string) gen_pers_event =
('person, 'string) Def.gen_pers_event = {
epers_name : 'string gen_pers_event_name;
epers_date : cdate;
epers_place : 'string;
epers_reason : 'string;
epers_note : 'string;
epers_src : 'string;
epers_witnesses : ('person * witness_kind) array;
}
type 'string gen_fam_event_name = 'string Def.gen_fam_event_name =
| Efam_Marriage
| Efam_NoMarriage
| Efam_NoMention
| Efam_Engage
| Efam_Divorce
| Efam_Separated
| Efam_Annulation
| Efam_MarriageBann
| Efam_MarriageContract
| Efam_MarriageLicense
| Efam_PACS
| Efam_Residence
| Efam_Name of 'string
type ('person, 'string) gen_fam_event = ('person, 'string) Def.gen_fam_event = {
efam_name : 'string gen_fam_event_name;
efam_date : cdate;
efam_place : 'string;
efam_reason : 'string;
efam_note : 'string;
efam_src : 'string;
efam_witnesses : ('person * witness_kind) array;
}
type relation_type = Def.relation_type =
| Adoption
| Recognition
| CandidateParent
| GodParent
| FosterParent
type ('person, 'string) gen_relation = ('person, 'string) Def.gen_relation = {
r_type : relation_type;
r_fath : 'person option;
r_moth : 'person option;
r_sources : 'string;
}
type sex = Def.sex = Male | Female | Neuter
type place = Def.place = {
other : string;
town : string;
township : string;
canton : string;
district : string;
county : string;
region : string;
country : string;
}
(* person *)
type ('iper, 'person, 'string) gen_person =
('iper, 'person, 'string) Def.gen_person = {
first_name : 'string;
surname : 'string;
occ : int;
image : 'string;
public_name : 'string;
qualifiers : 'string list;
aliases : 'string list;
first_names_aliases : 'string list;
surnames_aliases : 'string list;
titles : 'string gen_title list;
rparents : ('person, 'string) gen_relation list;
related : 'person list;
occupation : 'string;
sex : sex;
access : access;
birth : cdate;
birth_place : 'string;
birth_note : 'string;
birth_src : 'string;
baptism : cdate;
baptism_place : 'string;
baptism_note : 'string;
baptism_src : 'string;
death : death;
death_place : 'string;
death_note : 'string;
death_src : 'string;
burial : burial;
burial_place : 'string;
burial_note : 'string;
burial_src : 'string;
pevents : ('person, 'string) gen_pers_event list;
notes : 'string;
psources : 'string;
key_index : 'iper;
}
type 'family gen_ascend = 'family Def.gen_ascend = {
parents : 'family option;
consang : fix;
}
type 'family gen_union = 'family Def.gen_union = { family : 'family array }
(* family *)
type ('person, 'ifam, 'string) gen_family =
('person, 'ifam, 'string) Def.gen_family = {
marriage : cdate;
marriage_place : 'string;
marriage_note : 'string;
marriage_src : 'string;
witnesses : 'person array;
relation : relation_kind;
divorce : divorce;
fevents : ('person, 'string) gen_fam_event list;
comment : 'string;
origin_file : 'string;
fsources : 'string;
fam_index : 'ifam;
}
type 'person gen_couple = 'person Def.gen_couple (* FIXME: expose its type *)
type 'person gen_descend = 'person Def.gen_descend = {
children : 'person array;
}
type dsk_person = (int, int, int) gen_person
(** Extended person's entry in the base *)
type dsk_ascend = int gen_ascend
(** Person's ascendants entry in the base *)
type dsk_union = int gen_union
(** Person's union entry in the base *)
type dsk_family = (int, int, int) gen_family
(** Family's entry in the base *)
type dsk_couple = int gen_couple
(** Family's couple entry in the base *)
type dsk_descend = int gen_descend
(** Family's descendants entry in the base *)
type dsk_title = int gen_title
(** Nobility title in the base *)
type 'a record_access = {
(* Load array in the memory and cache it so it could be accessed
instantly by other functions unless [clear_array] is called. *)
load_array : unit -> unit;
(* Get the nth element of array. In details, it searches for an element in
the following order:
- Search inside the pending patches
- Search inside the commited patches
- Search insede the loaded in memory array
- Search inside the "base" file *)
get : int -> 'a;
(* Same as [get] but doesn't consider pending patches *)
get_nopending : int -> 'a;
(* Set the nth element of array *)
set : int -> 'a -> unit;
(* Return length of an array that by default takes into account
commited patches *)
mutable len : int;
(* Output array with applied commited patches to the giving chanel *)
output_array : out_channel -> unit;
(* Remove array from the memory *)
clear_array : unit -> unit;
}
(** Type that define the functions to use to access and manipulate with
database arrays. *)
type string_person_index = {
(* Find all person's ids that has giving surname/first name. *)
find : int -> int list;
(* Return surname's/first name's id. If it doen't present return id of the next
name by alphabetical order *)
cursor : string -> int;
(* Return surname's/first name's id. If it doen't present return id of the next
name by alphabetical order *)
next : int -> int;
}
(** Data structure for optimised search throughout index by name
(surname or first name). Considers also patched persons. *)
type visible_record_access = {
v_write : unit -> unit;
v_get : (dsk_person -> bool) -> int -> bool;
}
type perm = RDONLY | RDRW
type base_data = {
(* Array of persons *)
persons : dsk_person record_access;
(* Array of persons' ascendants *)
ascends : dsk_ascend record_access;
(* Array of persons' unions *)
unions : dsk_union record_access;
(* unused by default *)
visible : visible_record_access;
(* Array of families *)
families : dsk_family record_access;
(* Array of families' couples *)
couples : dsk_couple record_access;
(* Array of families' descendants *)
descends : dsk_descend record_access;
(* Array of strings *)
strings : string record_access;
(* Array of autorised to use surname's particles *)
particles_txt : string list;
(* Regular expression that matches particles in [particles_txt] *)
particles : Re.re Lazy.t;
(* Data base notes and extended page structure *)
bnotes : Def.base_notes;
(* Directory where database's files are stored *)
bdir : string;
perm : perm;
}
(** Data part of database *)
type base_func = {
(* Return person's id from the giving key (first name, surname and occurene number).
If person doesn't exists return None. Doesn't consider pending patches *)
person_of_key : string -> string -> int -> int option;
(* Return list of person ids that have giving name
(could be one of the mix). Doesn't consider pending patches *)
persons_of_name : string -> int list;
(* Return list of surnames (string ids) that contain giving person's surname or surname substring.
Consider also surnames of pathed persons. Doesn't consider pending patches *)
strings_of_sname : string -> int list;
(* Return list of first names (string ids) that contain giving person's first name or first name's
substring. Consider also first names of pathed persons. Doesn't consider pending patches *)
strings_of_fname : string -> int list;
(* Search functionalities throughout index by surname *)
persons_of_surname : string_person_index;
(* Search functionalities throughout index by first name *)
persons_of_first_name : string_person_index;
(* Insert or modify person with a giving id (add to pending patches). *)
patch_person : int -> dsk_person -> unit;
(* Insert or modify ascendants of a person with a giving id (add to pending patches). *)
patch_ascend : int -> dsk_ascend -> unit;
(* Insert or modify union of a person with a giving id (add to pending patches). *)
patch_union : int -> dsk_union -> unit;
(* Insert or modify family with a giving id (add to pending patches). *)
patch_family : int -> dsk_family -> unit;
(* Insert or modify couple of a family with a giving id (add to pending patches). *)
patch_couple : int -> dsk_couple -> unit;
(* Insert or modify descendants of a family with a giving id (add to pending patches). *)
patch_descend : int -> dsk_descend -> unit;
(* Associate person to [name] inside the index.
Added directly inside commited patches. *)
patch_name : string -> int -> unit;
(* Insert new string inside the pending patches and returns its id.
If string already exists return its id. *)
insert_string : string -> int;
(* Commit pending patches and write a patches' new state inside "patches"
file. "nb_persons" is also updated. *)
commit_patches : unit -> unit;
(* Update content (second arg) of the notes' file (first arg) if exists. *)
commit_notes : string -> string -> unit;
(* Close every opened channel. *)
cleanup : unit -> unit;
(* Returns real number of persons inside the base (without empty persons).
Pending patches aren't considered. *)
nb_of_real_persons : unit -> int;
(* Tells if person with giving id exists in the base.
Pending patches are also considered. *)
iper_exists : int -> bool;
(* Tells if family with giving id exists in the base.
Pending patches are also considered. *)
ifam_exists : int -> bool;
}
(** Functionality part of database. Every modification of the base is stored in {i patches} file.
Note that, every modification firstly is pendent and should be commited
to apply them and to update {i patches} file with [commit_patches]. *)
(** Geneweb database version *)
type base_version = GnWb0020 | GnWb0021 | GnWb0022 | GnWb0023 | GnWb0024
type dsk_base = { data : base_data; func : base_func; version : base_version }
(** Database representation: data and basic requests over this data. *)

7
lib/gwdb-legacy/dune Normal file
View File

@@ -0,0 +1,7 @@
(library
(name gwdb_legacy)
(public_name geneweb.gwdb-legacy)
(implements geneweb.gwdb_driver)
(libraries geneweb.def geneweb.util re unix)
(modules_without_implementation dbdisk)
(modules btree database dbdisk dutil gwdb_driver gwdb_gc iovalue outbase))

76
lib/gwdb-legacy/dutil.ml Normal file
View File

@@ -0,0 +1,76 @@
(* Copyright (c) 2006-2007 INRIA *)
open Dbdisk
open Def
type name_index_data = int array array
type strings_of_fsname = int array array
let magic_GnWb0020 = "GnWb0020"
let magic_GnWb0021 = "GnWb0021"
let magic_GnWb0022 = "GnWb0022"
let magic_GnWb0023 = "GnWb0023"
let magic_GnWb0024 = "GnWb0024"
let table_size = 0x3fff
let poi base i = base.data.persons.get i
let aoi base i = base.data.ascends.get i
let uoi base i = base.data.unions.get i
let coi base i = base.data.couples.get i
let sou base i = base.data.strings.get i
let p_first_name base p = Mutil.nominative (sou base p.first_name)
let p_surname base p = Mutil.nominative (sou base p.surname)
let husbands base p =
Array.map
(fun ifam ->
let cpl = coi base ifam in
let husband = poi base (Adef.father cpl) in
let husband_surname = husband.surname in
let husband_surnames_aliases = husband.surnames_aliases in
(husband_surname, husband_surnames_aliases))
(uoi base p.key_index).family
let father_titles_places base p nobtit =
match (aoi base p.key_index).parents with
| Some ifam ->
let cpl = coi base ifam in
let fath = poi base (Adef.father cpl) in
nobtit fath
| None -> []
let dsk_person_misc_names base p nobtit =
Futil.gen_person_misc_names (sou base) 0 1 p.first_name p.surname
p.public_name p.qualifiers p.aliases p.first_names_aliases
p.surnames_aliases (nobtit p)
(if p.sex = Female then husbands base p else [||])
(father_titles_places base p nobtit)
let compare_snames base_data s1 s2 =
Mutil.compare_after_particle (Lazy.force base_data.particles) s1 s2
let compare_snames_i base_data is1 is2 =
if is1 = is2 then 0
else
compare_snames base_data
(base_data.strings.get is1)
(base_data.strings.get is2)
let compare_fnames = String.compare
let compare_fnames_i base_data is1 is2 =
if is1 = is2 then 0
else compare_fnames (base_data.strings.get is1) (base_data.strings.get is2)
let int_size = 4
let output_value_no_sharing oc v =
Marshal.to_channel oc v [ Marshal.No_sharing ]
module IntHT = Hashtbl.Make (struct
type t = int
let equal = ( = )
let hash x = x
end)
let name_index s = Hashtbl.hash (Name.crush_lower s) mod table_size

78
lib/gwdb-legacy/dutil.mli Normal file
View File

@@ -0,0 +1,78 @@
(* Copyright (c) 2006-2007 INRIA *)
open Dbdisk
type name_index_data = int array array
(** Index for all kind of mix between person's names (first index inside {i names.inx}) *)
type strings_of_fsname = int array array
(** Index for sub-strings of person's surame and first name (second and third index respectively inside {i names.inx}) *)
val magic_GnWb0020 : string
(** Header for the {i base} file (version 0020) *)
val magic_GnWb0021 : string
(** Header for the {i base} file (version 0021) *)
val magic_GnWb0022 : string
(** Header for the {i base} file (version 0022) *)
val magic_GnWb0023 : string
(** Header for the {i base} file (version 0023) *)
val magic_GnWb0024 : string
(** Header for the latest version of {i base} file *)
val table_size : int
(** Maximal size of hash table for name indexation (inside {i names.inx}) *)
val compare_fnames_i : Dbdisk.base_data -> int -> int -> int
(** [compare_fnames_i base i1 i2] compare two first names that have indexes [i1] and [i2] inside the [base]. *)
val compare_fnames : string -> string -> int
(** [compare_fnames] compare two first names. *)
val compare_snames_i : Dbdisk.base_data -> int -> int -> int
(** [compare_snames_i base i1 i2] compare two surnames that have indexes [i1] and [i2] inside the [base]. *)
val compare_snames : Dbdisk.base_data -> string -> string -> int
(** [compare_snames_i base s1 s2] compare two surnames according to the principe specified by [Mutil.compare_after_particle]. *)
val dsk_person_misc_names :
dsk_base -> dsk_person -> (dsk_person -> dsk_title list) -> string list
(** [dsk_person_misc_names base p nobtit] computes various mix between all kind of names of a person's entry [p]
from the database [base]. [nobtit] is used to return a title entries for passed in argument person. *)
val poi : dsk_base -> int -> dsk_person
(** [poi base i] returns person's entry with index [i] from [base]. *)
val sou : dsk_base -> int -> string
(** [poi base i] returns string with index [i] from [base]. *)
val p_first_name : dsk_base -> dsk_person -> string
(** Returns person's first name from the given person's entry. *)
val p_surname : dsk_base -> dsk_person -> string
(** Returns person's surname from the given person's entry. *)
val output_value_no_sharing : out_channel -> _ -> unit
(** Output given value to the channel. Uses [Marshall.to_channel] with [No_sharing] flag. *)
val int_size : int
(** Size of integer value inside the Geneweb's binary files *)
(** Hastable that has unhashed int as a key. *)
module IntHT : sig
include module type of Hashtbl.Make (struct
type t = int
let equal = ( = )
let hash x = x
end)
end
val name_index : string -> int
(** [name_index s]
Compute the index of crush_lowered version of s
in an array of size [table_size].
*)

571
lib/gwdb-legacy/gwdb_driver.ml Normal file
View File

@@ -0,0 +1,571 @@
(* Copyright (c) 1998-2007 INRIA *)
open Dbdisk
type istr = int
type ifam = int
type iper = int
let string_of_iper = string_of_int
let string_of_ifam = string_of_int
let string_of_istr = string_of_int
let iper_of_string = int_of_string
let ifam_of_string = int_of_string
let istr_of_string = int_of_string
let dummy_iper = -1
let dummy_ifam = -1
let empty_string = 0
let quest_string = 1
let eq_istr i1 i2 = i1 = i2
let eq_ifam i1 i2 = i1 = i2
let eq_iper i1 i2 = i1 = i2
let is_empty_string istr = istr = 0
let is_quest_string istr = istr = 1
type string_person_index = Dbdisk.string_person_index
let spi_find spi = spi.find
let spi_first spi = spi.cursor
let spi_next (spi : string_person_index) istr = spi.next istr
type base = dsk_base
let open_base bname : base = Database.opendb bname
let sou base i = base.data.strings.get i
let bname base = Filename.(remove_extension @@ basename base.data.bdir)
let nb_of_persons base = base.data.persons.len
let nb_of_real_persons base = base.func.nb_of_real_persons ()
let nb_of_families base = base.data.families.len
let insert_string base s =
base.func.Dbdisk.insert_string @@ Mutil.normalize_utf_8 s
let commit_patches base = base.func.Dbdisk.commit_patches ()
let commit_notes base s = base.func.Dbdisk.commit_notes s
let person_of_key base = base.func.Dbdisk.person_of_key
let persons_of_name base = base.func.Dbdisk.persons_of_name
let persons_of_first_name base = base.func.Dbdisk.persons_of_first_name
let persons_of_surname base = base.func.Dbdisk.persons_of_surname
let base_particles base = Lazy.force base.data.particles
let base_strings_of_first_name base s = base.func.strings_of_fname s
let base_strings_of_surname base s = base.func.strings_of_sname s
let load_ascends_array base = base.data.ascends.load_array ()
let load_unions_array base = base.data.unions.load_array ()
let load_couples_array base = base.data.couples.load_array ()
let load_descends_array base = base.data.descends.load_array ()
let load_strings_array base = base.data.strings.load_array ()
let load_persons_array base = base.data.persons.load_array ()
let load_families_array base = base.data.families.load_array ()
let clear_ascends_array base = base.data.ascends.clear_array ()
let clear_unions_array base = base.data.unions.clear_array ()
let clear_couples_array base = base.data.couples.clear_array ()
let clear_descends_array base = base.data.descends.clear_array ()
let clear_strings_array base = base.data.strings.clear_array ()
let clear_persons_array base = base.data.persons.clear_array ()
let clear_families_array base = base.data.families.clear_array ()
let close_base base =
base.func.cleanup ();
clear_ascends_array base;
clear_unions_array base;
clear_couples_array base;
clear_descends_array base;
clear_strings_array base;
clear_persons_array base;
clear_families_array base;
()
let date_of_last_change base =
let s =
let bdir = base.data.bdir in
try Unix.stat (Filename.concat bdir "patches")
with Unix.Unix_error (_, _, _) -> Unix.stat (Filename.concat bdir "base")
in
s.Unix.st_mtime
let gen_gen_person_misc_names = Dutil.dsk_person_misc_names
let patch_misc_names base ip (p : (iper, iper, istr) Def.gen_person) =
let p = { p with Def.key_index = ip } in
List.iter
(fun s -> base.func.Dbdisk.patch_name s ip)
(gen_gen_person_misc_names base p (fun p -> p.Def.titles))
let patch_person base ip (p : (iper, iper, istr) Def.gen_person) =
base.func.Dbdisk.patch_person ip p;
let s = sou base p.first_name ^ " " ^ sou base p.surname in
base.func.Dbdisk.patch_name s ip;
patch_misc_names base ip p;
Array.iter
(fun i ->
let cpl = base.data.couples.get i in
let m = Adef.mother cpl in
let f = Adef.father cpl in
patch_misc_names base m (base.data.persons.get m);
patch_misc_names base f (base.data.persons.get f);
Array.iter
(fun i -> patch_misc_names base i (base.data.persons.get i))
(base.data.descends.get i).children)
(base.data.unions.get ip).family
let patch_ascend base ip a = base.func.Dbdisk.patch_ascend ip a
let patch_union base ip u = base.func.Dbdisk.patch_union ip u
let patch_family base ifam f = base.func.Dbdisk.patch_family ifam f
let patch_couple base ifam c = base.func.Dbdisk.patch_couple ifam c
let patch_descend base ifam d = base.func.Dbdisk.patch_descend ifam d
let insert_person = patch_person
let insert_ascend = patch_ascend
let insert_union = patch_union
let insert_family = patch_family
let insert_couple = patch_couple
let insert_descend = patch_descend
let delete_person base ip =
patch_person base ip
{
first_name = quest_string;
surname = quest_string;
occ = 0;
image = empty_string;
first_names_aliases = [];
surnames_aliases = [];
public_name = empty_string;
qualifiers = [];
titles = [];
rparents = [];
related = [];
aliases = [];
occupation = empty_string;
sex = Neuter;
access = Private;
birth = Date.cdate_None;
birth_place = empty_string;
birth_note = empty_string;
birth_src = empty_string;
baptism = Date.cdate_None;
baptism_place = empty_string;
baptism_note = empty_string;
baptism_src = empty_string;
death = DontKnowIfDead;
death_place = empty_string;
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 = empty_string;
key_index = ip;
}
let delete_ascend base ip =
patch_ascend base ip { parents = None; consang = Adef.no_consang }
let delete_union base ip = patch_union base ip { family = [||] }
let delete_family base ifam =
patch_family base ifam
{
marriage = Date.cdate_None;
marriage_place = empty_string;
marriage_note = empty_string;
marriage_src = empty_string;
relation = Married;
divorce = NotDivorced;
fevents = [];
witnesses = [||];
comment = empty_string;
origin_file = empty_string;
fsources = empty_string;
fam_index = dummy_ifam;
}
let delete_couple base ifam =
patch_couple base ifam (Adef.couple dummy_iper dummy_iper)
let delete_descend base ifam = patch_descend base ifam { children = [||] }
let new_iper base = base.data.persons.len
let new_ifam base = base.data.families.len
(* FIXME: lock *)
let sync ?(scratch = false) base =
if base.data.perm = RDONLY && not scratch then
raise Def.(HttpExn (Forbidden, __LOC__))
else Outbase.output base
let make bname particles arrays : Dbdisk.dsk_base =
sync ~scratch:true (Database.make bname particles arrays);
open_base bname
let bfname base fname = Filename.concat base.data.bdir fname
module NLDB = struct
let magic = "GWNL0010"
let read base =
let fname = bfname base "notes_links" in
match try Some (open_in_bin fname) with Sys_error _ -> None with
| Some ic ->
let r =
if Mutil.check_magic magic ic then
(input_value ic : (iper, iper) Def.NLDB.t)
else failwith "unsupported nldb format"
in
close_in ic;
r
| None -> []
let write base db =
if base.data.perm = RDONLY then raise Def.(HttpExn (Forbidden, __LOC__))
else
let fname_tmp = bfname base "1notes_links" in
let fname_def = bfname base "notes_links" in
let fname_back = bfname base "notes_links~" in
let oc = open_out_bin fname_tmp in
output_string oc magic;
output_value oc (db : (iper, ifam) Def.NLDB.t);
close_out oc;
Mutil.rm fname_back;
Mutil.mv fname_def fname_back;
Sys.rename fname_tmp fname_def
end
let read_nldb = NLDB.read
let write_nldb = NLDB.write
let base_notes_origin_file base = base.data.bnotes.Def.norigin_file
let base_notes_dir _base = "notes_d"
let base_wiznotes_dir _base = "wiznotes"
let base_notes_read_aux base fnotes mode =
let fname =
if fnotes = "" then "notes" else Filename.concat "notes_d" (fnotes ^ ".txt")
in
try
let ic = Secure.open_in @@ Filename.concat base.data.bdir fname in
let str =
match mode with
| Def.RnDeg -> if in_channel_length ic = 0 then "" else " "
| Def.Rn1Ln -> ( try input_line ic with End_of_file -> "")
| Def.RnAll -> Mutil.input_file_ic ic
in
close_in ic;
str
with Sys_error _ -> ""
let base_notes_read base fnotes = base_notes_read_aux base fnotes Def.RnAll
let base_notes_read_first_line base fnotes =
base_notes_read_aux base fnotes Def.Rn1Ln
let base_notes_are_empty base fnotes =
base_notes_read_aux base fnotes Def.RnDeg = ""
type relation = (iper, istr) Def.gen_relation
type title = istr Def.gen_title
type pers_event = (iper, istr) Def.gen_pers_event
type fam_event = (iper, istr) Def.gen_fam_event
let cache f a get set x =
match get x with
| Some v -> v
| None ->
let v = f a in
set x (Some v);
v
(** Persons *)
type person = {
base : base;
iper : iper;
mutable p : (iper, iper, istr) gen_person option;
mutable a : ifam gen_ascend option;
mutable u : ifam gen_union option;
}
let cache_per f ({ base; iper; _ } as p) =
f (cache base.data.persons.get iper (fun p -> p.p) (fun p v -> p.p <- v) p)
let cache_asc f ({ base; iper; _ } as p) =
f (cache base.data.ascends.get iper (fun p -> p.a) (fun p v -> p.a <- v) p)
let cache_uni f ({ base; iper; _ } as p) =
f (cache base.data.unions.get iper (fun p -> p.u) (fun p v -> p.u <- v) p)
let gen_person_of_person = cache_per (fun p -> p)
let gen_ascend_of_person = cache_asc (fun p -> p)
let gen_union_of_person = cache_uni (fun p -> p)
let get_access = cache_per (fun p -> p.Def.access)
let get_aliases = cache_per (fun p -> p.Def.aliases)
let get_baptism = cache_per (fun p -> p.Def.baptism)
let get_baptism_note = cache_per (fun p -> p.Def.baptism_note)
let get_baptism_place = cache_per (fun p -> p.Def.baptism_place)
let get_baptism_src = cache_per (fun p -> p.Def.baptism_src)
let get_birth = cache_per (fun p -> p.Def.birth)
let get_birth_note = cache_per (fun p -> p.Def.birth_note)
let get_birth_place = cache_per (fun p -> p.Def.birth_place)
let get_birth_src = cache_per (fun p -> p.Def.birth_src)
let get_burial = cache_per (fun p -> p.Def.burial)
let get_burial_note = cache_per (fun p -> p.Def.burial_note)
let get_burial_place = cache_per (fun p -> p.Def.burial_place)
let get_burial_src = cache_per (fun p -> p.Def.burial_src)
let get_consang = cache_asc (fun a -> a.Def.consang)
let get_death = cache_per (fun p -> p.Def.death)
let get_death_note = cache_per (fun p -> p.Def.death_note)
let get_death_place = cache_per (fun p -> p.Def.death_place)
let get_death_src = cache_per (fun p -> p.Def.death_src)
let get_family = cache_uni (fun u -> u.Def.family)
let get_first_name = cache_per (fun p -> p.Def.first_name)
let get_first_names_aliases = cache_per (fun p -> p.Def.first_names_aliases)
let get_image = cache_per (fun p -> p.Def.image)
let get_iper = cache_per (fun p -> p.Def.key_index)
let get_notes = cache_per (fun p -> p.Def.notes)
let get_occ = cache_per (fun p -> p.Def.occ)
let get_occupation = cache_per (fun p -> p.Def.occupation)
let get_parents = cache_asc (fun a -> a.Def.parents)
let get_pevents = cache_per (fun p -> p.Def.pevents)
let get_psources = cache_per (fun p -> p.Def.psources)
let get_public_name = cache_per (fun p -> p.Def.public_name)
let get_qualifiers = cache_per (fun p -> p.Def.qualifiers)
let get_related = cache_per (fun p -> p.Def.related)
let get_rparents = cache_per (fun p -> p.Def.rparents)
let get_sex = cache_per (fun p -> p.Def.sex)
let get_surname = cache_per (fun p -> p.Def.surname)
let get_surnames_aliases = cache_per (fun p -> p.Def.surnames_aliases)
let get_titles = cache_per (fun p -> p.Def.titles)
(** Families *)
type family = {
base : base;
ifam : ifam;
mutable f : (iper, ifam, istr) gen_family option;
mutable c : iper gen_couple option;
mutable d : iper gen_descend option;
}
let cache_fam f ({ base; ifam; _ } as fam) =
f (cache base.data.families.get ifam (fun f -> f.f) (fun f v -> f.f <- v) fam)
let cache_cpl f ({ base; ifam; _ } as fam) =
f (cache base.data.couples.get ifam (fun f -> f.c) (fun f v -> f.c <- v) fam)
let cache_des f ({ base; ifam; _ } as fam) =
f (cache base.data.descends.get ifam (fun f -> f.d) (fun f v -> f.d <- v) fam)
let gen_couple_of_family = cache_cpl (fun c -> c)
let gen_descend_of_family = cache_des (fun d -> d)
let gen_family_of_family = cache_fam (fun f -> f)
let get_children = cache_des (fun d -> d.Def.children)
let get_comment = cache_fam (fun f -> f.Def.comment)
let get_ifam = cache_fam (fun f -> f.Def.fam_index)
let get_divorce = cache_fam (fun f -> f.Def.divorce)
let get_father = cache_cpl (fun c -> Adef.father c)
let get_fevents = cache_fam (fun f -> f.Def.fevents)
let get_fsources = cache_fam (fun f -> f.Def.fsources)
let get_marriage = cache_fam (fun f -> f.Def.marriage)
let get_marriage_note = cache_fam (fun f -> f.Def.marriage_note)
let get_marriage_place = cache_fam (fun f -> f.Def.marriage_place)
let get_marriage_src = cache_fam (fun f -> f.Def.marriage_src)
let get_mother = cache_cpl (fun c -> Adef.mother c)
let get_origin_file = cache_fam (fun f -> f.Def.origin_file)
let get_parent_array = cache_cpl (fun c -> Adef.parent_array c)
let get_relation = cache_fam (fun f -> f.Def.relation)
let get_witnesses = cache_fam (fun f -> f.Def.witnesses)
let no_person ip =
{ (Mutil.empty_person empty_string empty_string) with key_index = ip }
let no_ascend = { parents = None; consang = Adef.no_consang }
let no_union = { family = [||] }
let empty_person base iper =
{
base;
iper;
p = Some (no_person iper);
a = Some no_ascend;
u = Some no_union;
}
[@ocaml.warning "-42"]
let person_of_gen_person base (p, a, u) =
{ base; iper = p.key_index; p = Some p; a = Some a; u = Some u }
[@ocaml.warning "-42"]
let family_of_gen_family base (f, c, d) =
{ base; ifam = f.fam_index; f = Some f; c = Some c; d = Some d }
[@ocaml.warning "-42"]
let iper_exists base = base.func.iper_exists
let ifam_exists base = base.func.ifam_exists
let poi base iper =
if iper = dummy_iper then empty_person base iper
else { base; iper; p = None; a = None; u = None } [@ocaml.warning "-42"]
let no_family ifam = { (Mutil.empty_family empty_string) with fam_index = ifam }
let no_couple = Adef.couple dummy_iper dummy_iper
let no_descend = { Def.children = [||] }
let empty_family base ifam =
{
base;
ifam;
f = Some (no_family ifam);
c = Some no_couple;
d = Some no_descend;
}
let foi base ifam =
if ifam = dummy_ifam then empty_family base ifam
else { base; ifam; f = None; c = None; d = None }
module Collection = struct
type 'a t = { length : int; get : int -> 'a option }
let map (fn : 'a -> 'b) c =
{
length = c.length;
get = (fun i -> match c.get i with Some x -> Some (fn x) | None -> None);
}
let length { length; _ } = length
let iter fn { get; length } =
for i = 0 to length - 1 do
match get i with Some x -> fn x | None -> ()
done
let iteri fn { get; length } =
for i = 0 to length - 1 do
match get i with Some x -> fn i x | None -> ()
done
let fold ?from ?until fn acc { get; length } =
let from = match from with Some x -> x | None -> 0 in
let until = match until with Some x -> x + 1 | None -> length in
let rec loop acc i =
if i = until then acc
else loop (match get i with Some x -> fn acc x | None -> acc) (i + 1)
in
loop acc from
let fold_until continue fn acc { get; length } =
let rec loop acc i =
if (not (continue acc)) || i = length then acc
else loop (match get i with Some x -> fn acc x | None -> acc) (i + 1)
in
loop acc 0
let iterator { get; length } =
let cursor = ref 0 in
let rec next () =
if !cursor < length then (
match get !cursor with
| None ->
incr cursor;
next ()
| v ->
incr cursor;
v)
else None
in
next
end
module Marker = struct
type ('k, 'v) t = { get : 'k -> 'v; set : 'k -> 'v -> unit }
let make (k : 'a -> int) (c : 'a Collection.t) (i : 'v) : ('a, 'v) t =
let a = Array.make c.Collection.length i in
{
get = (fun x -> Array.get a (k x));
set = (fun x v -> Array.set a (k x) v);
}
let get ({ get; _ } : _ t) k = get k
let set ({ set; _ } : _ t) k = set k
end
let persons base =
{ Collection.length = nb_of_persons base; get = (fun i -> Some (poi base i)) }
let ipers base =
{ Collection.length = nb_of_persons base; get = (fun i -> Some i) }
let iper_marker c i = Marker.make (fun i -> i) c i
let ifams ?(select = fun _ -> true) base =
{
Collection.length = nb_of_families base;
get =
(fun i ->
if select i then
if get_ifam (foi base i) = dummy_ifam then None else Some i
else None);
}
let families ?(select = fun _ -> true) base =
{
Collection.length = nb_of_families base;
get =
(fun i ->
let f = foi base i in
if get_ifam f <> dummy_ifam && select f then Some f else None);
}
let dummy_collection _ = { Collection.length = -1; get = (fun _ -> None) }
let ifam_marker c i = Marker.make (fun i -> i) c i
let dummy_marker (_ : 'a) (v : 'b) : ('a, 'b) Marker.t =
{ Marker.get = (fun _ -> v); set = (fun _ _ -> ()) }
(* Restrict file *)
(* FIXME: these values should not be global *)
let visible_ref : (iper, bool) Hashtbl.t option ref = ref None
let read_or_create_visible base =
let fname = Filename.concat base.data.bdir "restrict" in
let visible =
if Sys.file_exists fname then (
let ic = Secure.open_in fname in
let visible =
if Mutil.check_magic Mutil.executable_magic ic then input_value ic
else Hashtbl.create (nb_of_persons base)
in
close_in ic;
visible)
else Hashtbl.create (nb_of_persons base)
in
visible_ref := Some visible;
visible
let base_visible_write base =
if base.data.perm = RDONLY then raise Def.(HttpExn (Forbidden, __LOC__))
else
let fname = Filename.concat base.data.bdir "restrict" in
match !visible_ref with
| Some visible ->
let oc = Secure.open_out fname in
output_string oc Mutil.executable_magic;
output_value oc visible;
close_out oc
| None -> ()
let base_visible_get base fct i =
let visible =
match !visible_ref with
| Some visible -> visible
| None -> read_or_create_visible base
in
match Hashtbl.find_opt visible i with
| None ->
let status = fct (poi base i) in
Hashtbl.add visible i status;
visible_ref := Some visible;
status
| Some b -> b

187
lib/gwdb-legacy/gwdb_gc.ml Normal file
View File

@@ -0,0 +1,187 @@
open Dbdisk
(* copied from Gwdb_driver *)
let dummy_ifam = -1
let empty_string = 0
let quest_string = 1
let empty_person p =
(p.first_name = empty_string || p.first_name = quest_string)
&& (p.surname = empty_string || p.surname = quest_string)
(* && p.occ = 0 *)
&& p.image = empty_string
&& p.first_names_aliases = [] && p.surnames_aliases = []
&& p.public_name = empty_string
&& p.qualifiers = [] && p.titles = [] && p.rparents = [] && p.related = []
&& p.aliases = []
&& p.occupation = empty_string
&& p.sex = Neuter
(* && p.access = Private *)
&& p.birth = Date.cdate_None
&& p.birth_place = empty_string
&& p.birth_note = empty_string
&& p.birth_src = empty_string
&& p.baptism = Date.cdate_None
&& p.baptism_place = empty_string
&& p.baptism_note = empty_string
&& p.baptism_src = empty_string
&& p.death = DontKnowIfDead
&& p.death_place = empty_string
&& p.death_note = empty_string
&& p.death_src = empty_string && p.burial = UnknownBurial
&& p.burial_place = empty_string
&& p.burial_note = empty_string
&& p.burial_src = empty_string
&& p.pevents = [] && p.notes = empty_string && p.psources = empty_string
let gc ?(dry_run = true) base =
base.data.persons.load_array ();
base.data.ascends.load_array ();
base.data.unions.load_array ();
base.data.families.load_array ();
base.data.couples.load_array ();
base.data.descends.load_array ();
base.data.strings.load_array ();
let mp = Array.make base.data.persons.len false in
let mf = Array.make base.data.families.len false in
let ms = Array.make base.data.strings.len false in
let markp i = Array.set mp i true in
let markf i = Array.set mf i true in
let marks i = Array.set ms i true in
marks 0;
marks 1;
for i = 0 to base.data.persons.len - 1 do
let p = base.data.persons.get i in
if not (empty_person p) then (
markp i;
let _ = Futil.map_person_ps markp marks p in
let _ = Futil.map_union_f markf @@ base.data.unions.get i in
let _ = Futil.map_ascend_f markf @@ base.data.ascends.get i in
())
done;
for i = 0 to base.data.families.len - 1 do
if Array.get mf i then
let f = base.data.families.get i in
(* if family wasn't deleted *)
if f.fam_index <> dummy_ifam then
let _ = Futil.map_family_ps markp markf marks f in
let _ = Futil.map_couple_p false markp @@ base.data.couples.get i in
let _ = Futil.map_descend_p markp @@ base.data.descends.get i in
()
done;
(* [p1;p2:p3;p4] [true;false;true;false] -> [0;0;1;1] *)
let dst_i src m =
let off = ref 0 in
Array.init src.len (fun i ->
if Array.get m i then i - !off
else (
incr off;
i - !off))
in
(* 2 [true;false;true;false] -> [0;2] *)
let src_i len m =
let off = ref 0 in
let a = Array.make len (-1) in
let rec loop i =
if i = len then ()
else if Array.get m (i + !off) then (
Array.set a i (i + !off);
loop (i + 1))
else (
incr off;
loop i)
in
loop 0;
a
in
let aux arr =
let rec loop i (sum, acc) =
if i < 0 then (sum, acc)
else if Array.get arr i then loop (pred i) (succ sum, acc)
else loop (pred i) (sum, i :: acc)
in
loop (Array.length arr - 1) (0, [])
in
let lenp, deletedp = aux mp in
let lenf, deletedf = aux mf in
let lens, deleteds = aux ms in
if dry_run then (deletedp, deletedf, deleteds)
else
let dst_ipers = dst_i base.data.persons mp in
let dst_ifams = dst_i base.data.families mf in
let dst_istrs = dst_i base.data.strings ms in
let dst_iper = Array.get dst_ipers in
let dst_ifam = Array.get dst_ifams in
let dst_istr = Array.get dst_istrs in
let src_ipers = src_i lenp mp in
let src_ifams = src_i lenf mf in
let src_istrs = src_i lens ms in
let src_iper = Array.get src_ipers in
let src_ifam = Array.get src_ifams in
let src_istr = Array.get src_istrs in
let persons =
Array.init lenp @@ fun i ->
{
(Futil.map_person_ps dst_iper dst_istr
@@ base.data.persons.get @@ src_iper i)
with
key_index = i;
}
in
let ascends =
Array.init lenp @@ fun i ->
Futil.map_ascend_f dst_ifam @@ base.data.ascends.get @@ src_iper i
in
let unions =
Array.init lenp @@ fun i ->
Futil.map_union_f dst_ifam @@ base.data.unions.get @@ src_iper i
in
let families =
Array.init lenf @@ fun i ->
Futil.map_family_ps dst_iper (fun _ -> i) dst_istr
@@ base.data.families.get @@ src_ifam i
in
let couples =
Array.init lenf @@ fun i ->
Futil.map_couple_p false dst_iper @@ base.data.couples.get @@ src_ifam i
in
let descends =
Array.init lenf @@ fun i ->
Futil.map_descend_p dst_iper @@ base.data.descends.get @@ src_ifam i
in
let strings =
Array.init lens (fun i -> base.data.strings.get @@ src_istr i)
in
let bnotes = base.data.bnotes in
let particles = base.data.particles_txt in
let bname = base.data.bdir in
base.data.persons.clear_array ();
base.data.ascends.clear_array ();
base.data.unions.clear_array ();
base.data.families.clear_array ();
base.data.couples.clear_array ();
base.data.descends.clear_array ();
base.data.strings.clear_array ();
let base' =
Database.make bname particles
( (persons, ascends, unions),
(families, couples, descends),
strings,
bnotes )
in
base'.data.persons.load_array ();
base'.data.ascends.load_array ();
base'.data.unions.load_array ();
base'.data.families.load_array ();
base'.data.couples.load_array ();
base'.data.descends.load_array ();
base'.data.strings.load_array ();
Outbase.output base';
base'.data.persons.clear_array ();
base'.data.ascends.clear_array ();
base'.data.unions.clear_array ();
base'.data.families.clear_array ();
base'.data.couples.clear_array ();
base'.data.descends.clear_array ();
base'.data.strings.clear_array ();
(deletedp, deletedf, deleteds)

7
lib/gwdb-legacy/gwdb_gc.mli Normal file
View File

@@ -0,0 +1,7 @@
val gc : ?dry_run:bool -> Dbdisk.dsk_base -> int list * int list * int list
(** [gc ~dry_run base] launch garbage collector over that analyse database [base] that detects
all deleted or empty elements that aren't referenced by anyone (unmarked element). If [dry_run]
is unset then performs memory compacting by eliminating all unmarked elements from all database
arrays and update corresponding database on the disk. Otherwise, it just perform computing stage
without database update. Returns [(deletedp,deletedf,deleteds)] where [deletedp] is ids of all unmarked
persons, [deletedf] is ids of all unmarked families and [deleteds] is ids of all unmarked strings *)

211
lib/gwdb-legacy/iovalue.ml Normal file
View File

@@ -0,0 +1,211 @@
(* $Id: iovalue.ml,v 5.15 2012-01-27 16:27:46 ddr Exp $ *)
(* Copyright (c) 1998-2007 INRIA *)
(* Input:
read inside a value output by output_value (no headers) must
match OCaml's input_value system (intern.c) *)
let sizeof_long = 4
let sign_extend_shift = (((Sys.word_size / 8) - 1) * 8) - 1
let sign_extend x = (x lsl sign_extend_shift) asr sign_extend_shift
let prefix_SMALL_BLOCK = 0x80
let prefix_SMALL_INT = 0x40
let prefix_SMALL_STRING = 0x20
let code_INT8 = 0x0
let code_INT16 = 0x1
let code_INT32 = 0x2
let code_INT64 = 0x3
let code_BLOCK32 = 0x8
let code_BLOCK64 = 0x13
let code_STRING8 = 0x9
let code_STRING32 = 0xA
type 'a in_funs = {
input_byte : 'a -> int;
input_binary_int : 'a -> int;
input : 'a -> bytes -> int -> int -> unit;
}
let input_binary_int64 ifuns ic =
let rec loop cnt n =
if cnt = 0 then n else loop (cnt - 1) ((n lsl 8) + ifuns.input_byte ic)
in
loop 8 0
let rec input_loop ifuns ic =
let code = ifuns.input_byte ic in
if code >= prefix_SMALL_INT then
if code >= prefix_SMALL_BLOCK then
input_block ifuns ic (code land 0xf) ((code lsr 4) land 0x7)
else Obj.magic (code land 0x3f)
else if code >= prefix_SMALL_STRING then (
let len = code land 0x1F in
let s = Bytes.create len in
ifuns.input ic s 0 len;
Obj.magic s)
else if code = code_INT8 then Obj.magic (sign_extend (ifuns.input_byte ic))
else if code = code_INT16 then
let h = ifuns.input_byte ic in
Obj.magic ((sign_extend h lsl 8) + ifuns.input_byte ic)
else if code = code_INT32 then
let x1 = ifuns.input_byte ic in
let x2 = ifuns.input_byte ic in
let x3 = ifuns.input_byte ic in
let x4 = ifuns.input_byte ic in
Obj.magic ((sign_extend x1 lsl 24) + (x2 lsl 16) + (x3 lsl 8) + x4)
else if code = code_INT64 then
let () = assert (Sys.word_size = 64) in
Obj.magic (input_binary_int64 ifuns ic)
else if code = code_BLOCK32 then
let header = ifuns.input_binary_int ic in
Obj.magic (input_block ifuns ic (header land 0xff) (header lsr 10))
else if code = code_BLOCK64 then
if Sys.word_size = 64 then
let header = input_binary_int64 ifuns ic in
Obj.magic (input_block ifuns ic (header land 0xff) (header lsr 10))
else failwith "input bad code block 64"
else if code = code_STRING8 then (
let len = ifuns.input_byte ic in
let s = Bytes.create len in
ifuns.input ic s 0 len;
Obj.magic s)
else if code = code_STRING32 then (
let len = ifuns.input_binary_int ic in
let s = Bytes.create len in
ifuns.input ic s 0 len;
Obj.magic s)
else failwith (Printf.sprintf "input bad code 0x%x" code)
and input_block ifuns ic tag size =
let v =
if tag = 0 then Obj.magic (Array.make size (Obj.magic 0))
else Obj.new_block tag size
in
for i = 0 to size - 1 do
let x = input_loop ifuns ic in
Obj.set_field v i (Obj.magic x)
done;
v
let in_channel_funs = { input_byte; input_binary_int; input = really_input }
let input ic = Obj.magic (input_loop in_channel_funs ic)
(* Output *)
type 'a out_funs = {
output_byte : 'a -> int -> unit;
output_binary_int : 'a -> int -> unit;
output : 'a -> string -> int -> int -> unit;
}
let size_32 = ref 0
let size_64 = ref 0
let output_binary_int64 ofuns oc x =
for i = 1 to 8 do
ofuns.output_byte oc ((x lsr (64 - (8 * i))) land 0xFF)
done
let gen_output_block_header ofuns oc tag size =
let hd = (size lsl 10) + tag in
if tag < 16 && size < 8 then
ofuns.output_byte oc (prefix_SMALL_BLOCK + tag + (size lsl 4))
else if Sys.word_size = 64 && hd >= 1 lsl 32 then (
ofuns.output_byte oc code_BLOCK64;
output_binary_int64 ofuns oc hd)
else (
ofuns.output_byte oc code_BLOCK32;
(* hd = size << 10 + tag *)
ofuns.output_byte oc ((size lsr 14) land 0xFF);
ofuns.output_byte oc ((size lsr 6) land 0xFF);
ofuns.output_byte oc ((size lsl 2) land 0xFF);
ofuns.output_byte oc (((size lsl 10) land 0xFF) + tag));
if size = 0 then ()
else (
size_32 := !size_32 + 1 + size;
size_64 := !size_64 + 1 + size)
let rec output_loop ofuns oc x =
if Obj.is_int x then
if Obj.magic x >= 0 && Obj.magic x < 0x40 then
ofuns.output_byte oc (prefix_SMALL_INT + Obj.magic x)
else if Obj.magic x >= -128 && Obj.magic x < 128 then (
ofuns.output_byte oc code_INT8;
ofuns.output_byte oc (Obj.magic x))
else if Obj.magic x >= -32768 && Obj.magic x <= 32767 then (
ofuns.output_byte oc code_INT16;
ofuns.output_byte oc (Obj.magic x lsr 8);
ofuns.output_byte oc (Obj.magic x))
else if Obj.magic x >= -1073741824 && Obj.magic x <= 1073741823 then (
ofuns.output_byte oc code_INT32;
ofuns.output_binary_int oc (Obj.magic x))
else (
ofuns.output_byte oc code_INT64;
output_binary_int64 ofuns oc (Obj.magic x))
else if Obj.tag x = Obj.string_tag then (
let len = String.length (Obj.magic x) in
if len < 0x20 then ofuns.output_byte oc (prefix_SMALL_STRING + len)
else if len < 0x100 then (
ofuns.output_byte oc code_STRING8;
ofuns.output_byte oc len)
else (
ofuns.output_byte oc code_STRING32;
ofuns.output_binary_int oc len);
ofuns.output oc (Obj.magic x) 0 len;
size_32 := !size_32 + 1 + ((len + 4) / 4);
size_64 := !size_64 + 1 + ((len + 8) / 8))
else if Obj.tag x = Obj.double_tag || Obj.tag x = Obj.double_array_tag then
failwith "Iovalue.output: floats not implemented"
else if Obj.tag x = Obj.closure_tag then failwith "Iovalue.output <fun>"
else if Obj.tag x = Obj.abstract_tag then failwith "Iovalue.output <abstract>"
else if Obj.tag x = Obj.infix_tag then failwith "Iovalue.output: <infix>"
else if Obj.tag x = Obj.custom_tag then failwith "Iovalue.output: <custom>"
else if Obj.tag x = Obj.out_of_heap_tag then
failwith "Iovalue.output: abstract value (outside heap)"
else (
gen_output_block_header ofuns oc (Obj.tag x) (Obj.size x);
(* last case of "for" separated, to make more tail recursive cases
when last field is itself, to prevent some stacks overflows *)
if Obj.size x > 0 then (
for i = 0 to Obj.size x - 2 do
output_loop ofuns oc (Obj.field x i)
done;
output_loop ofuns oc (Obj.field x (Obj.size x - 1))))
let out_channel_funs =
{ output_byte; output_binary_int; output = output_substring }
let output oc x = output_loop out_channel_funs oc (Obj.repr x)
let gen_output ofuns i x = output_loop ofuns i (Obj.repr x)
(* Size *)
let size_funs =
{
output_byte = (fun r _ -> incr r);
output_binary_int = (fun r _ -> r := !r + 4);
output = (fun r _ beg len -> r := !r + len - beg);
}
let size = ref 0
let size v =
size := 0;
gen_output size_funs size v;
!size
let output_value_header_size = 20
let array_header_size arr_len =
if arr_len < 8 then 1
else if Sys.word_size = 64 && arr_len lsl 10 >= 1 lsl 32 then 9
else 5
let output_array_access oc arr_get arr_len pos =
let rec loop pos i =
if i = arr_len then pos
else (
output_binary_int oc pos;
loop (pos + size (arr_get i)) (i + 1))
in
loop (pos + output_value_header_size + array_header_size arr_len) 0

18
lib/gwdb-legacy/iovalue.mli Normal file
View File

@@ -0,0 +1,18 @@
(* $Id: iovalue.mli,v 5.5 2012-01-27 08:53:53 ddr Exp $ *)
(* Copyright (c) 1998-2007 INRIA *)
val sizeof_long : int
(** Size of long integer value inside the Geneweb's binary files *)
val input : in_channel -> 'a
(** Input a value from the giving channel. Identical to [Marshal.from_channel]. *)
val output : out_channel -> 'a -> unit
(** Output a value to the giving channel. Identical to [Marshal.to_channel] with [No_sharing] flag. *)
val output_array_access : out_channel -> (int -> 'a) -> int -> int -> int
(** [output_array_acces oc getf arr_get arr_len pos] prints to the channel
[oc] position for each element (that could be obtained with [arr_get])
in the binary file where marshalled array is stored. Array should be
of length [arr_len] and should start at the position [pos] inside the
binary file. Returns a position just after the end of array. *)

390
lib/gwdb-legacy/outbase.ml Normal file
View File

@@ -0,0 +1,390 @@
(* Copyright (c) 2006-2007 INRIA *)
open Dbdisk
let load_ascends_array base = base.data.ascends.load_array ()
let load_unions_array base = base.data.unions.load_array ()
let load_couples_array base = base.data.couples.load_array ()
let load_descends_array base = base.data.descends.load_array ()
let load_strings_array base = base.data.strings.load_array ()
let close_base base = base.func.cleanup ()
let save_mem = ref false
let verbose = Mutil.verbose
let trace s =
if !verbose then (
Printf.eprintf "*** %s\n" s;
flush stderr)
let count_error computed found =
Printf.eprintf "Count error. Computed %d. Found %d.\n" computed found;
flush stderr;
exit 2
let output_index_aux oc_inx oc_inx_acc ni =
let bpos = pos_out oc_inx in
(* output name index (circular hash table) in the "names.inx" and position for hashed value in the "names.acc" *)
Dutil.output_value_no_sharing oc_inx ni;
let epos =
Iovalue.output_array_access oc_inx_acc (Array.get ni) (Array.length ni) bpos
in
if epos <> pos_out oc_inx then count_error epos (pos_out oc_inx)
let make_name_index base =
let t = Array.make Dutil.table_size [] in
for i = 0 to base.data.persons.len - 1 do
let p = base.data.persons.get i in
(* not ? ? *)
if p.first_name <> 1 && p.first_name <> 1 then
List.iter (fun i -> Array.set t i @@ (p.key_index :: Array.get t i))
@@ Mutil.list_map_sort_uniq Dutil.name_index
@@ Dutil.dsk_person_misc_names base p (fun p -> p.titles)
done;
Array.map Array.of_list t
let create_name_index oc_inx oc_inx_acc base =
output_index_aux oc_inx oc_inx_acc (make_name_index base)
module IntSet = Set.Make (struct
type t = int
let compare = compare
end)
let make_strings_of_fsname_aux split get base =
let t = Array.make Dutil.table_size IntSet.empty in
let add_name (key : string) (value : int) =
let key = Dutil.name_index key in
let set = Array.get t key in
let set' = IntSet.add value set in
if set == set' then () else Array.set t key set'
in
for i = 0 to base.data.persons.len - 1 do
let p = Dutil.poi base i in
let aux istr =
if istr <> 1 then (
let s = base.data.strings.get istr in
add_name s istr;
split (fun i j -> add_name (String.sub s i j) istr) s)
in
aux (get p)
done;
Array.map
(fun set ->
let a = Array.make (IntSet.cardinal set) 0 in
let i = ref 0 in
IntSet.iter
(fun e ->
Array.set a !i e;
incr i)
set;
a)
t
let make_strings_of_fname =
make_strings_of_fsname_aux Name.split_fname_callback (fun p -> p.first_name)
let make_strings_of_sname =
make_strings_of_fsname_aux Name.split_sname_callback (fun p -> p.surname)
let create_strings_of_sname oc_inx oc_inx_acc base =
output_index_aux oc_inx oc_inx_acc (make_strings_of_sname base)
let create_strings_of_fname oc_inx oc_inx_acc base =
output_index_aux oc_inx oc_inx_acc (make_strings_of_fname base)
let is_prime a =
let rec loop b =
if a / b < b then true else if a mod b = 0 then false else loop (b + 1)
in
loop 2
let rec prime_after n = if is_prime n then n else prime_after (n + 1)
let output_strings_hash tmp_strings_inx base =
let oc = Secure.open_out_bin tmp_strings_inx in
let () = base.data.strings.load_array () in
let strings_array = base.data.strings in
let taba =
Array.make
(min Sys.max_array_length (prime_after (max 2 (10 * strings_array.len))))
(-1)
in
let tabl = Array.make strings_array.len (-1) in
for i = 0 to strings_array.len - 1 do
let ia = Hashtbl.hash (base.data.strings.get i) mod Array.length taba in
(* store last associated value associated to the same hash *)
tabl.(i) <- taba.(ia);
taba.(ia) <- i
done;
output_binary_int oc (Array.length taba);
for i = 0 to Array.length taba - 1 do
output_binary_int oc taba.(i)
done;
for i = 0 to Array.length tabl - 1 do
output_binary_int oc tabl.(i)
done;
close_out oc
(* Associate istr to persons.
A person is associated with its first name/surname and aliases
*)
let output_name_index_aux cmp get base names_inx names_dat =
let ht = Dutil.IntHT.create 0 in
for i = 0 to base.data.persons.len - 1 do
let p = base.data.persons.get i in
let k = get p in
match Dutil.IntHT.find_opt ht k with
| Some list -> Dutil.IntHT.replace ht k (p.key_index :: list)
| None -> Dutil.IntHT.add ht k [ p.key_index ]
done;
let a = Array.make (Dutil.IntHT.length ht) (0, []) in
ignore
@@ Dutil.IntHT.fold
(fun k v i ->
Array.set a i (k, v);
succ i)
ht 0;
(* sort by name behind the int order *)
Array.sort (fun (k, _) (k', _) -> cmp k k') a;
let oc_n_dat = Secure.open_out_bin names_dat in
let bt2 =
Array.map
(fun (k, ipl) ->
let off = pos_out oc_n_dat in
output_binary_int oc_n_dat (List.length ipl);
List.iter (output_binary_int oc_n_dat) ipl;
(k, off))
a
in
close_out oc_n_dat;
let oc_n_inx = Secure.open_out_bin names_inx in
Dutil.output_value_no_sharing oc_n_inx (bt2 : (int * int) array);
close_out oc_n_inx
let output_surname_index base tmp_snames_inx tmp_snames_dat =
output_name_index_aux
(Dutil.compare_snames_i base.data)
(fun p -> p.surname)
base tmp_snames_inx tmp_snames_dat
let output_first_name_index base tmp_fnames_inx tmp_fnames_dat =
output_name_index_aux
(Dutil.compare_fnames_i base.data)
(fun p -> p.first_name)
base tmp_fnames_inx tmp_fnames_dat
let output_particles_file particles fname =
let oc = open_out fname in
List.iter (fun s -> Printf.fprintf oc "%s\n" (Mutil.tr ' ' '_' s)) particles;
close_out oc
let output base =
(* create database directory *)
let bname = base.data.bdir in
if not (Sys.file_exists bname) then Unix.mkdir bname 0o755;
(* temporary files *)
let tmp_particles = Filename.concat bname "1particles.txt" in
let tmp_base = Filename.concat bname "1base" in
let tmp_base_acc = Filename.concat bname "1base.acc" in
let tmp_names_inx = Filename.concat bname "1names.inx" in
let tmp_names_acc = Filename.concat bname "1names.acc" in
let tmp_snames_inx = Filename.concat bname "1snames.inx" in
let tmp_snames_dat = Filename.concat bname "1snames.dat" in
let tmp_fnames_inx = Filename.concat bname "1fnames.inx" in
let tmp_fnames_dat = Filename.concat bname "1fnames.dat" in
let tmp_strings_inx = Filename.concat bname "1strings.inx" in
let tmp_notes = Filename.concat bname "1notes" in
let tmp_notes_d = Filename.concat bname "1notes_d" in
load_ascends_array base;
load_unions_array base;
load_couples_array base;
load_descends_array base;
load_strings_array base;
let oc = Secure.open_out_bin tmp_base in
let oc_acc = Secure.open_out_bin tmp_base_acc in
let output_array arrname arr =
let bpos = pos_out oc in
if !verbose then Printf.eprintf "*** saving %s array\n" arrname;
flush stderr;
arr.output_array oc;
let epos = Iovalue.output_array_access oc_acc arr.get arr.len bpos in
if epos <> pos_out oc then count_error epos (pos_out oc)
in
(try
(* output header of "base" *)
output_string oc Dutil.magic_GnWb0024;
output_binary_int oc base.data.persons.len;
output_binary_int oc base.data.families.len;
output_binary_int oc base.data.strings.len;
let array_start_indexes = pos_out oc in
output_binary_int oc 0;
output_binary_int oc 0;
output_binary_int oc 0;
output_binary_int oc 0;
output_binary_int oc 0;
output_binary_int oc 0;
output_binary_int oc 0;
Dutil.output_value_no_sharing oc
(base.data.bnotes.Def.norigin_file : string);
(* output arrays in the "base" and position for each element in the "base.acc" *)
let persons_array_pos = pos_out oc in
output_array "persons" base.data.persons;
let ascends_array_pos = pos_out oc in
output_array "ascends" base.data.ascends;
let unions_array_pos = pos_out oc in
output_array "unions" base.data.unions;
let families_array_pos = pos_out oc in
output_array "families" base.data.families;
let couples_array_pos = pos_out oc in
output_array "couples" base.data.couples;
let descends_array_pos = pos_out oc in
output_array "descends" base.data.descends;
let strings_array_pos = pos_out oc in
output_array "strings" base.data.strings;
(* output arrays position in the header *)
seek_out oc array_start_indexes;
output_binary_int oc persons_array_pos;
output_binary_int oc ascends_array_pos;
output_binary_int oc unions_array_pos;
output_binary_int oc families_array_pos;
output_binary_int oc couples_array_pos;
output_binary_int oc descends_array_pos;
output_binary_int oc strings_array_pos;
base.data.families.clear_array ();
base.data.descends.clear_array ();
close_out oc;
close_out oc_acc;
(let oc_inx = Secure.open_out_bin tmp_names_inx in
let oc_inx_acc = Secure.open_out_bin tmp_names_acc in
try
trace "create name index";
output_binary_int oc_inx 0;
(* room for sname index *)
output_binary_int oc_inx 0;
(* room for fname index *)
create_name_index oc_inx oc_inx_acc base;
base.data.ascends.clear_array ();
base.data.unions.clear_array ();
base.data.couples.clear_array ();
if !save_mem then (
trace "compacting";
Gc.compact ());
let surname_pos = pos_out oc_inx in
trace "create strings of sname";
create_strings_of_sname oc_inx oc_inx_acc base;
let first_name_pos = pos_out oc_inx in
trace "create strings of fname";
create_strings_of_fname oc_inx oc_inx_acc base;
seek_out oc_inx 0;
(* sname index *)
output_binary_int oc_inx surname_pos;
seek_out oc_inx 1;
(* fname index *)
output_binary_int oc_inx first_name_pos;
close_out oc_inx;
close_out oc_inx_acc;
if !save_mem then (
trace "compacting";
Gc.compact ());
Gc.compact ();
trace "create string index";
output_strings_hash tmp_strings_inx base;
if !save_mem then (
trace "compacting";
Gc.compact ());
trace "create surname index";
output_surname_index base tmp_snames_inx tmp_snames_dat;
if !save_mem then (
trace "compacting";
Gc.compact ());
trace "create first name index";
output_first_name_index base tmp_fnames_inx tmp_fnames_dat;
let s = base.data.bnotes.Def.nread "" Def.RnAll in
(if s = "" then ()
else
let oc_not = Secure.open_out tmp_notes in
output_string oc_not s;
close_out oc_not);
List.iter
(fun f ->
let s = base.data.bnotes.Def.nread f Def.RnAll in
let fname = Filename.concat tmp_notes_d (f ^ ".txt") in
Mutil.mkdir_p (Filename.dirname fname);
let oc = open_out fname in
output_string oc s;
close_out oc)
(List.rev (base.data.bnotes.Def.efiles ()));
output_particles_file base.data.particles_txt tmp_particles
with e ->
(try close_out oc_inx with _ -> ());
(try close_out oc_inx_acc with _ -> ());
raise e);
trace "ok";
let nbp =
let rec loop i acc =
if i = base.data.persons.len then acc
else
let p = base.data.persons.get i in
let acc =
if
p.key_index = -1
|| (0 = p.surname || 1 = p.surname)
&& (0 = p.first_name || 1 = p.first_name)
then acc
else acc + 1
in
loop (i + 1) acc
in
loop 0 0
in
let oc = Secure.open_out_bin @@ Filename.concat bname "nb_persons" in
output_value oc nbp;
close_out oc
with e ->
(try close_out oc with _ -> ());
(try close_out oc_acc with _ -> ());
Mutil.rm tmp_base;
Mutil.rm tmp_base_acc;
Mutil.rm tmp_names_inx;
Mutil.rm tmp_names_acc;
Mutil.rm tmp_strings_inx;
Mutil.remove_dir tmp_notes_d;
raise e);
close_base base;
Mutil.rm (Filename.concat bname "base");
Sys.rename tmp_base (Filename.concat bname "base");
Mutil.rm (Filename.concat bname "base.acc");
Sys.rename tmp_base_acc (Filename.concat bname "base.acc");
Mutil.rm (Filename.concat bname "names.inx");
Sys.rename tmp_names_inx (Filename.concat bname "names.inx");
Mutil.rm (Filename.concat bname "names.acc");
Sys.rename tmp_names_acc (Filename.concat bname "names.acc");
Mutil.rm (Filename.concat bname "snames.dat");
Sys.rename tmp_snames_dat (Filename.concat bname "snames.dat");
Mutil.rm (Filename.concat bname "snames.inx");
Sys.rename tmp_snames_inx (Filename.concat bname "snames.inx");
Mutil.rm (Filename.concat bname "fnames.dat");
Sys.rename tmp_fnames_dat (Filename.concat bname "fnames.dat");
Mutil.rm (Filename.concat bname "fnames.inx");
Sys.rename tmp_fnames_inx (Filename.concat bname "fnames.inx");
Mutil.rm (Filename.concat bname "strings.inx");
Sys.rename tmp_strings_inx (Filename.concat bname "strings.inx");
Sys.rename tmp_particles (Filename.concat bname "particles.txt");
Mutil.rm (Filename.concat bname "notes");
if Sys.file_exists tmp_notes then
Sys.rename tmp_notes (Filename.concat bname "notes");
if Sys.file_exists tmp_notes_d then (
let notes_d = Filename.concat bname "notes_d" in
Mutil.remove_dir notes_d;
Sys.rename tmp_notes_d notes_d);
Mutil.rm (Filename.concat bname "patches");
Mutil.rm (Filename.concat bname "patches~");
Mutil.rm (Filename.concat bname "synchro_patches");
Mutil.rm (Filename.concat bname "notes_link");
Mutil.rm (Filename.concat bname "restrict");
Mutil.rm (Filename.concat bname "tstab_visitor");
Mutil.rm (Filename.concat bname "nb_persons");
(* FIXME: should not be present in this part of the code? *)
Mutil.rm (Filename.concat bname "tstab");
Mutil.rm (Filename.concat bname "tstab_visitor")

28
lib/gwdb-legacy/outbase.mli Normal file
View File

@@ -0,0 +1,28 @@
val save_mem : bool ref
(** Flag that enables memory saving by calling gc sometimes *)
val output : Dbdisk.dsk_base -> unit
(** [output base] uses data section of the [base] to store database on the disk in the files:
- {i base} main file that stores all the arrays of the database
- {i base.acc} direct accesses to arrays inside {i base} (list of offsets for every array)
- {i names.inx} 3 different name indexes :
- For all kind of mix between person's names. Associate hash value
of the name to the array of persons (index of its entry) containing the given name
- sub-strings of surname. Associate hash value of the sub-string to
the array of string indexes of the names that contains mentionned sub string.
- sub-strings of first name. Same storage principe as for surname sub-strings.
- {i names.acc} direct accesses to arrays inside {i names.inx}.
- {i strings.inx} strings index. Associate hash of the string to the index
of its entry in the base's string array. Save also previus value in the case of
collision of hash.
- {i snames.inx} ordered index for surnames. Associate index of surname to its offset in
{i snames.dat}.
- {i snames.dat} For a giving surname give associated list of perosons (index of its entry)
- {i fnames.inx} and {i fnames.dat} same as for {i snames.inx} and {i snames.dat} but deals
with first names
- {i notes} text file containing data base notes.
- {i notes_d} directory containing .txt for each extended page.
- {i particles.txt} text file with autorised name's particles.
*)

947
lib/gwdb-versioned/gwdb_driver.ml Normal file
View File

@@ -0,0 +1,947 @@
module type Data = sig
type t
type index = int
type base
val patch_file : base -> string
val data_file : base -> string
val directory : base -> string
val tmp_file : string -> string
end
module Store (D : Data) : sig
val get : D.base -> D.index -> D.t option
val set : D.base -> D.index -> D.t option -> unit
val unsafe_set : D.index -> D.t option -> unit
val write : D.base -> unit
val sync : (D.base -> D.t option array) -> D.base -> unit
val empty : unit -> unit
val close_data_file : unit -> unit
val move_data_file : D.base -> unit
val move_patch_file : D.base -> unit
val remove_patch_file : D.base -> unit
end = struct
type t = (D.index, D.t option) Hashtbl.t
let patch_ht : (D.index, D.t option) Hashtbl.t option ref = ref None
let data_file_in_channel : in_channel option ref = ref None
let cache_ht : (D.index, D.t option) Hashtbl.t option ref = ref None
let open_data_file base =
match !data_file_in_channel with
| Some ic ->
seek_in ic 0;
ic
| None ->
let file = D.data_file base in
let ic = Secure.open_in file in
data_file_in_channel := Some ic;
ic
let close_data_file () =
match !data_file_in_channel with
| Some ic ->
close_in ic;
data_file_in_channel := None
| None -> ()
let patch_file_exists base = Sys.file_exists (D.patch_file base)
let data_file_exists base = Sys.file_exists (D.data_file base)
let directory_exists base = Sys.file_exists (D.directory base)
let create_files base = Files.mkdir_p (D.directory base)
let move_data_file base =
let dataf = D.data_file base in
let tmp = D.tmp_file dataf in
Files.mv tmp dataf
let move_patch_file base =
let patchf = D.patch_file base in
let tmp = D.tmp_file patchf in
Files.mv tmp patchf
let remove_patch_file base =
let patchf = D.patch_file base in
Files.rm patchf
let load_patch base =
if patch_file_exists base then (
let file = D.patch_file base in
let ic = Secure.open_in file in
let tbl = (Marshal.from_channel ic : t) in
close_in ic;
patch_ht := Some tbl;
tbl)
else
let tbl = Hashtbl.create 1 in
patch_ht := Some tbl;
tbl
let patch base =
match !patch_ht with Some ht -> ht | None -> load_patch base
let cache () =
match !cache_ht with
| Some ht -> ht
| None ->
let tbl = Hashtbl.create 10 in
cache_ht := Some tbl;
tbl
let get_from_data_file base index =
if data_file_exists base then
let ic = open_data_file base in
let len = input_binary_int ic in
if not (index < len) then None
else (
assert (index < len);
seek_in ic (4 + (index * 4));
let pos_data = input_binary_int ic in
if pos_data <> -1 then (
seek_in ic pos_data;
let data = (Marshal.from_channel ic : D.t) in
let c = cache () in
Hashtbl.replace c index (Some data);
Some data)
else None)
else None
let get_from_cache _base index =
match !cache_ht with Some ht -> Hashtbl.find_opt ht index | None -> None
let get base index =
match Hashtbl.find_opt (patch base) index with
| Some v -> v
| None -> (
match get_from_cache base index with
| Some v -> v
| None -> get_from_data_file base index)
let set base index value =
let tbl = patch base in
Hashtbl.replace tbl index value
let unsafe_set index value =
let tbl = Option.get !patch_ht in
Hashtbl.replace tbl index value
let write base =
let tbl = patch base in
if not (directory_exists base) then create_files base;
let patchfile = D.patch_file base in
let patchfile_tmp = D.tmp_file patchfile in
if Sys.file_exists patchfile_tmp then
failwith "Error while writing patch file : temporary file remained";
let oc = Secure.open_out patchfile_tmp in
Marshal.to_channel oc tbl [ Marshal.No_sharing ];
close_out oc
let empty () =
patch_ht := Some (Hashtbl.create 1);
data_file_in_channel := None;
cache_ht := None
let load_data build_from_scratch base : D.t option array =
if not (data_file_exists base) then build_from_scratch base
else
let ic = open_data_file base in
let len = input_binary_int ic in
let get_pos i =
seek_in ic (4 + (4 * i));
let pos = input_binary_int ic in
pos
in
seek_in ic (4 + (4 * len));
let rec loop i l =
if i = 0 then l
else
let pos = get_pos (i - 1) in
if pos = -1 then loop (i - 1) (None :: l)
else (
seek_in ic pos;
let l = Some (Marshal.from_channel ic : D.t) :: l in
loop (i - 1) l)
in
let data = Array.of_list @@ loop len [] in
data
let sync build_from_scratch base =
if not (directory_exists base) then create_files base;
let tbl = patch base in
let data = load_data build_from_scratch base in
let dfile = D.data_file base in
let dfile_tmp = D.tmp_file dfile in
if Sys.file_exists dfile_tmp then
failwith "Error while writing data file : temporary file remained";
let oc = Secure.open_out dfile_tmp in
let syncdata = Hashtbl.create (Array.length data) in
Array.iteri (Hashtbl.add syncdata) data;
Hashtbl.iter (Hashtbl.replace syncdata) tbl;
let max_index, l =
Hashtbl.fold
(fun k v (max_index, l) ->
let max_index = max max_index k in
(max_index, (k, v) :: l))
syncdata (-1, [])
in
let a = Array.of_list l in
Array.sort (fun (k, _) (k', _) -> k - k') a;
let len = max_index + 1 in
let accesses = Array.make len (-1) in
output_binary_int oc len;
seek_out oc (4 + (len * 4));
Array.iter
(fun (index, data) ->
match data with
| Some data ->
let pos = pos_out oc in
Marshal.to_channel oc data [ Marshal.No_sharing ];
accesses.(index) <- pos
| None -> accesses.(index) <- -1)
a;
seek_out oc 4;
Array.iter (output_binary_int oc) accesses;
close_out oc;
close_data_file ()
end
module Legacy_driver = struct
include Gwdb_legacy.Gwdb_driver
let compatibility_directory = "gnwb25-2"
let compatibility_file = "witness_notes"
let fcompatibility_file = "fwitness_notes"
let data_file = "witness_notes.dat"
let fdata_file = "fwitness_notes.dat"
let directory base = Filename.concat (bdir base) compatibility_directory
let patch_file base = Filename.concat (directory base) compatibility_file
let data_file base = Filename.concat (directory base) data_file
let fpatch_file base = Filename.concat (directory base) fcompatibility_file
let fdata_file base = Filename.concat (directory base) fdata_file
let tmp_file fname = fname ^ "~"
module PersonData = struct
type t = istr array array
type index = iper
type base = Gwdb_legacy.Gwdb_driver.base
let directory = directory
let patch_file = patch_file
let data_file = data_file
let tmp_file = tmp_file
end
module PatchPer = Store (PersonData)
module FamilyData = struct
type t = istr array array
type index = ifam
type base = Gwdb_legacy.Gwdb_driver.base
let directory = directory
let patch_file = fpatch_file
let data_file = fdata_file
let tmp_file = tmp_file
end
module PatchFam = Store (FamilyData)
let versions = Version.[ gnwb20; gnwb21; gnwb22; gnwb23; gnwb24 ]
type person = {
person : Gwdb_legacy.Gwdb_driver.person;
base : Gwdb_legacy.Gwdb_driver.base;
mutable witness_notes : istr array array option;
}
type family = {
family : Gwdb_legacy.Gwdb_driver.family;
base : Gwdb_legacy.Gwdb_driver.base;
mutable witness_notes : istr array array option;
}
type pers_event = {
pevent : Gwdb_legacy.Gwdb_driver.pers_event;
event_index : int;
event_person : person;
mutable pwitness_notes : istr array option;
mutable witnesses : (iper * Def.witness_kind * istr) array option;
}
type fam_event = {
fevent : Gwdb_legacy.Gwdb_driver.fam_event;
event_index : int;
event_family : family;
mutable fwitness_notes : istr array option;
mutable witnesses : (iper * Def.witness_kind * istr) array option;
}
let poi_ht : (iper, person) Hashtbl.t option ref = ref None
let foi_ht : (ifam, family) Hashtbl.t option ref = ref None
let reset_poi_ht () =
match !poi_ht with
| Some ht ->
Hashtbl.clear ht;
poi_ht := None
| None -> ()
let reset_foi_ht () =
match !foi_ht with
| Some ht ->
Hashtbl.clear ht;
foi_ht := None
| None -> ()
let cache_foi_poi = ref true
let set_fpoi_cache _base b =
reset_poi_ht ();
reset_foi_ht ();
cache_foi_poi := b
let find_poi iper =
if not !cache_foi_poi then None
else
match !poi_ht with
| Some ht -> Hashtbl.find_opt ht iper
| None ->
poi_ht := Some (Hashtbl.create 1);
None
let find_foi ifam =
if not !cache_foi_poi then None
else
match !foi_ht with
| Some ht -> Hashtbl.find_opt ht ifam
| None ->
foi_ht := Some (Hashtbl.create 1);
None
let set_poi iper data =
if !cache_foi_poi then
match !poi_ht with Some ht -> Hashtbl.add ht iper data | _ -> ()
let set_foi ifam data =
if !cache_foi_poi then
match !foi_ht with Some ht -> Hashtbl.add ht ifam data | _ -> ()
let clear_poi iper =
match !poi_ht with Some ht -> Hashtbl.remove ht iper | _ -> ()
let clear_foi ifam =
match !foi_ht with Some ht -> Hashtbl.remove ht ifam | _ -> ()
let get_pers_full_wit_notes (p : person) =
match p.witness_notes with
| Some a when Array.length a > 0 ->
fun ie ->
if Array.length a.(ie) > 0 then fun iw -> a.(ie).(iw)
else fun _iw -> empty_string
| Some _a -> fun _ie _iw -> empty_string
| None -> (
let iper = Gwdb_legacy.Gwdb_driver.get_iper p.person in
if iper = dummy_iper then (
p.witness_notes <- Some [||];
fun _ie _iw -> empty_string)
else
let notes = PatchPer.get p.base iper in
match notes with
| Some wnotes ->
p.witness_notes <- notes;
fun ie ->
if Array.length wnotes.(ie) = 0 then fun _iw -> empty_string
else fun iw -> wnotes.(ie).(iw)
| None ->
p.witness_notes <- Some [||];
fun _ie _iw -> empty_string)
let get_pers_wit_notes (p : person) ie iw =
match p.witness_notes with
| Some a when Array.length a > 0 && Array.length a.(ie) > 0 -> a.(ie).(iw)
| Some _a -> empty_string
| None -> (
let iper = Gwdb_legacy.Gwdb_driver.get_iper p.person in
if iper = dummy_iper then (
p.witness_notes <- Some [||];
empty_string)
else
let notes = PatchPer.get p.base iper in
match notes with
| Some wnotes ->
p.witness_notes <- notes;
if Array.length wnotes.(ie) = 0 then empty_string
else wnotes.(ie).(iw)
| None ->
p.witness_notes <- Some [||];
empty_string)
let get_fam_full_wit_notes (f : family) =
match f.witness_notes with
| Some a when Array.length a > 0 ->
fun ie ->
if Array.length a.(ie) > 0 then fun iw -> a.(ie).(iw)
else fun _iw -> empty_string
| Some _a -> fun _ie _iw -> empty_string
| None -> (
let ifam = Gwdb_legacy.Gwdb_driver.get_ifam f.family in
if ifam = dummy_ifam then (
f.witness_notes <- Some [||];
fun _ie _iw -> empty_string)
else
let notes = PatchFam.get f.base ifam in
match notes with
| Some wnotes ->
f.witness_notes <- notes;
fun ie ->
if Array.length wnotes.(ie) = 0 then fun _iw -> empty_string
else fun iw -> wnotes.(ie).(iw)
| None ->
f.witness_notes <- Some [||];
fun _ie _iw -> empty_string)
let get_fam_wit_notes (f : family) ie iw =
match f.witness_notes with
| Some a when Array.length a > 0 && Array.length a.(ie) > 0 -> a.(ie).(iw)
| Some _a -> empty_string
| None -> (
let ifam = Gwdb_legacy.Gwdb_driver.get_ifam f.family in
if ifam = dummy_ifam then (
f.witness_notes <- Some [||];
empty_string)
else
let notes = PatchFam.get f.base ifam in
match notes with
| Some wnotes ->
f.witness_notes <- notes;
if Array.length wnotes.(ie) = 0 then empty_string
else wnotes.(ie).(iw)
| None ->
f.witness_notes <- Some [||];
empty_string)
let gen_person_of_person (p : person) =
let gen_pers = gen_person_of_person p.person in
let pevents =
List.mapi
(fun ie pe ->
let pe = Translate.legacy_to_def_pevent empty_string pe in
let epers_witnesses =
Array.mapi
(fun iw (ip, wk, _) -> (ip, wk, get_pers_wit_notes p ie iw))
pe.epers_witnesses
in
{ pe with epers_witnesses })
gen_pers.pevents
in
let gen_pers = Translate.legacy_to_def_person empty_string gen_pers in
{ gen_pers with pevents }
let person_of_gen_person base (genpers, gen_ascend, gen_union) =
let pevents = genpers.Def.pevents in
let witness_notes =
Some
(List.map
(fun pe ->
Array.map (fun (_, _, wnote) -> wnote) pe.Def.epers_witnesses)
pevents
|> Array.of_list)
in
let genpers = Translate.as_legacy_person genpers in
let person = person_of_gen_person base (genpers, gen_ascend, gen_union) in
{ person; base; witness_notes }
let no_person iper =
let nop = no_person iper in
Translate.legacy_to_def_person empty_string nop
let witness_notes_of_events pevents : istr array array option =
let l =
List.map
(fun pe ->
let a =
Array.map (fun (_, _, wnote) -> wnote) pe.Def.epers_witnesses
in
if Array.exists (fun wnote -> not (is_empty_string wnote)) a then a
else [||])
pevents
in
let has_data = List.exists (fun a -> Array.length a <> 0) l in
if has_data then Some (Array.of_list l) else None
let fwitness_notes_of_events fevents : istr array array option =
let l =
List.map
(fun fe ->
let a =
Array.map (fun (_, _, wnote) -> wnote) fe.Def.efam_witnesses
in
if Array.exists (fun wnote -> not (is_empty_string wnote)) a then a
else [||])
fevents
in
let has_data = List.exists (fun a -> Array.length a <> 0) l in
if has_data then Some (Array.of_list l) else None
let patch_person base iper genpers =
let pevents = genpers.Def.pevents in
let genpers = Translate.as_legacy_person genpers in
patch_person base iper genpers;
let witnotes = witness_notes_of_events pevents in
PatchPer.set base iper witnotes;
clear_poi iper
let insert_person base iper genpers =
let pevents = genpers.Def.pevents in
let genpers = Translate.as_legacy_person genpers in
insert_person base iper genpers;
let witnotes = witness_notes_of_events pevents in
PatchPer.set base iper witnotes;
clear_poi iper
let delete_person base iper =
Gwdb_legacy.Gwdb_driver.delete_person base iper;
clear_poi iper
let commit_patches base =
PatchPer.write base;
PatchFam.write base;
commit_patches base;
PatchPer.move_patch_file base;
PatchFam.move_patch_file base
let pwitness_notes_of_pevent (pe : pers_event) =
match pe.pwitness_notes with
| Some a -> a
| None ->
let wlen = Array.length pe.pevent.epers_witnesses in
let a =
Array.init wlen
(get_pers_full_wit_notes pe.event_person pe.event_index)
in
pe.pwitness_notes <- Some a;
a
let fwitness_notes_of_fevent (fe : fam_event) =
match fe.fwitness_notes with
| Some a -> a
| None ->
let wlen = Array.length fe.fevent.efam_witnesses in
let a =
Array.init wlen
(get_fam_full_wit_notes fe.event_family fe.event_index)
in
fe.fwitness_notes <- Some a;
a
let get_pevents (p : person) =
let pevents = Gwdb_legacy.Gwdb_driver.get_pevents p.person in
List.mapi
(fun ie pevent ->
{
pevent;
event_person = p;
event_index = ie;
pwitness_notes = None;
witnesses = None;
})
pevents
let get_pevent_name pe = pe.pevent.epers_name
let get_pevent_date pe = pe.pevent.epers_date
let get_pevent_place pe = pe.pevent.epers_place
let get_pevent_reason pe = pe.pevent.epers_reason
let get_pevent_note pe = pe.pevent.epers_note
let get_pevent_src pe = pe.pevent.epers_src
let get_pevent_witnesses pe = pe.pevent.epers_witnesses
let get_pevent_witness_notes pe = pwitness_notes_of_pevent pe
let get_pevent_witnesses_and_notes (pe : pers_event) =
match pe.witnesses with
| Some a -> a
| None ->
let len = Array.length pe.pevent.epers_witnesses in
let wnotes = pwitness_notes_of_pevent pe in
let a =
Array.init len (fun iw ->
let ip, wk = pe.pevent.epers_witnesses.(iw) in
let wnote = wnotes.(iw) in
(ip, wk, wnote))
in
pe.witnesses <- Some a;
a
let gen_pevent_of_pers_event pe =
let genpers = Translate.legacy_to_def_pevent empty_string pe.pevent in
let len = Array.length pe.pevent.epers_witnesses in
let wnotes = pwitness_notes_of_pevent pe in
let epers_witnesses =
Array.init len (fun i ->
let ip, wk = pe.pevent.epers_witnesses.(i) in
let wnote = wnotes.(i) in
(ip, wk, wnote))
in
{ genpers with epers_witnesses }
let pers_event_of_gen_pevent _base _genpers = assert false
let eq_pevent p1 p2 = p1.pevent = p2.pevent
let eq_fevent f1 f2 = f1.fevent = f2.fevent
let gen_fevent_of_fam_event fe =
let genfam = Translate.legacy_to_def_fevent empty_string fe.fevent in
let len = Array.length fe.fevent.efam_witnesses in
let wnotes = fwitness_notes_of_fevent fe in
let efam_witnesses =
Array.init len (fun i ->
let ip, wk = fe.fevent.efam_witnesses.(i) in
let wnote = wnotes.(i) in
(ip, wk, wnote))
in
{ genfam with efam_witnesses }
let fam_event_of_gen_fevent _base _genfam = assert false
let get_fevents (f : family) =
let fevents = Gwdb_legacy.Gwdb_driver.get_fevents f.family in
List.mapi
(fun ie fevent ->
{
fevent;
fwitness_notes = None;
event_index = ie;
witnesses = None;
event_family = f;
})
fevents
let get_fevent_name fe = fe.fevent.efam_name
let get_fevent_date fe = fe.fevent.efam_date
let get_fevent_place fe = fe.fevent.efam_place
let get_fevent_reason fe = fe.fevent.efam_reason
let get_fevent_note fe = fe.fevent.efam_note
let get_fevent_src fe = fe.fevent.efam_src
let get_fevent_witnesses fe = fe.fevent.efam_witnesses
let get_fevent_witness_notes fe = fwitness_notes_of_fevent fe
let get_fevent_witnesses_and_notes fe =
let len = Array.length fe.fevent.efam_witnesses in
let wnotes = fwitness_notes_of_fevent fe in
Array.init len (fun iw ->
let ip, wk = fe.fevent.efam_witnesses.(iw) in
let wnote = wnotes.(iw) in
(ip, wk, wnote))
let build_from_scratch_pevents base =
let persons = Gwdb_legacy.Gwdb_driver.persons base in
let max_index, data =
Gwdb_legacy.Gwdb_driver.Collection.fold
(fun (max_index, l) p ->
let iper = get_iper p in
(max max_index iper, (iper, None) :: l))
(0, []) persons
in
let d = Array.make (max_index + 1) None in
List.iter (fun (i, v) -> if i = -1 then () else Array.unsafe_set d i v) data;
d
let build_from_scratch_fevents base =
let families = Gwdb_legacy.Gwdb_driver.families base in
let max_index, data =
Gwdb_legacy.Gwdb_driver.Collection.fold
(fun (max_index, l) f ->
let ifam = get_ifam f in
(max max_index ifam, (ifam, None) :: l))
(0, []) families
in
let d = Array.make (max_index + 1) None in
List.iter (fun (i, v) -> if i = -1 then () else Array.unsafe_set d i v) data;
d
let sync ?(scratch = false) ~save_mem base =
let dir = Filename.concat (bdir base) compatibility_directory in
if scratch && Sys.file_exists dir then Files.remove_dir dir;
PatchPer.sync build_from_scratch_pevents base;
PatchFam.sync build_from_scratch_fevents base;
sync ~scratch ~save_mem base;
PatchPer.move_data_file base;
PatchPer.remove_patch_file base;
PatchFam.move_data_file base;
PatchFam.remove_patch_file base
let make bname particles
( (persons, ascends, unions),
(families, couples, descends),
string_arrays,
base_notes ) =
PatchPer.empty ();
PatchFam.empty ();
let persons =
Array.map
(fun p ->
let leg_person = Translate.as_legacy_person p in
PatchPer.unsafe_set p.key_index (witness_notes_of_events p.pevents);
leg_person)
persons
in
let families =
Array.map
(fun f ->
let leg_family = Translate.as_legacy_family f in
PatchFam.unsafe_set f.fam_index (fwitness_notes_of_events f.fevents);
leg_family)
families
in
let base =
make bname particles
( (persons, ascends, unions),
(families, couples, descends),
string_arrays,
base_notes )
in
let dir = Filename.concat (bdir base) compatibility_directory in
if Sys.file_exists dir then Files.remove_dir dir;
PatchPer.sync build_from_scratch_pevents base;
PatchFam.sync build_from_scratch_fevents base;
PatchPer.move_data_file base;
PatchFam.move_data_file base;
base
let open_base = open_base
let empty_person base iper =
let p = empty_person base iper in
{ person = p; base; witness_notes = Some [||] }
let get_access p = get_access p.person
let get_aliases p = get_aliases p.person
let get_baptism p = get_baptism p.person
let get_baptism_note p = get_baptism_note p.person
let get_baptism_place p = get_baptism_place p.person
let get_baptism_src p = get_baptism_src p.person
let get_birth p = get_birth p.person
let get_birth_note p = get_birth_note p.person
let get_birth_place p = get_birth_place p.person
let get_birth_src p = get_birth_src p.person
let get_death p = get_death p.person
let get_death_note p = get_death_note p.person
let get_death_place p = get_death_place p.person
let get_death_src p = get_death_src p.person
let get_burial p = get_burial p.person
let get_burial_note p = get_burial_note p.person
let get_burial_place p = get_burial_place p.person
let get_burial_src p = get_burial_src p.person
let get_consang p = get_consang p.person
let get_family p = get_family p.person
let get_first_name p = get_first_name p.person
let get_first_names_aliases p = get_first_names_aliases p.person
let get_image p = get_image p.person
let get_iper p = get_iper p.person
let get_notes p = get_notes p.person
let get_occ p = get_occ p.person
let get_occupation p = get_occupation p.person
let get_parents p = get_parents p.person
let get_psources p = get_psources p.person
let get_public_name p = get_public_name p.person
let get_qualifiers p = get_qualifiers p.person
let get_related p = get_related p.person
let get_rparents p = get_rparents p.person
let get_sex p = get_sex p.person
let get_surname p = get_surname p.person
let get_surnames_aliases p = get_surnames_aliases p.person
let get_titles p = get_titles p.person
let gen_ascend_of_person p = gen_ascend_of_person p.person
let gen_union_of_person p = gen_union_of_person p.person
let poi base iper =
match find_poi iper with
| Some p -> p
| None ->
let p = { person = poi base iper; base; witness_notes = None } in
set_poi iper p;
p
let base_visible_get base (f : person -> bool) iper =
let f person = f { person; base; witness_notes = None } in
base_visible_get base f iper
let persons base =
let coll = persons base in
Collection.map (fun person -> { person; base; witness_notes = None }) coll
let empty_family base ifam =
let f = empty_family base ifam in
{ family = f; base; witness_notes = Some [||] }
let gen_family_of_family f =
let gen_fam = gen_family_of_family f.family in
let fevents =
List.mapi
(fun ie fe ->
let fe = Translate.legacy_to_def_fevent empty_string fe in
let efam_witnesses =
Array.mapi
(fun iw (ip, wk, _) -> (ip, wk, get_fam_wit_notes f ie iw))
fe.efam_witnesses
in
{ fe with efam_witnesses })
gen_fam.fevents
in
let gen_fam = Translate.legacy_to_def_family empty_string gen_fam in
{ gen_fam with fevents }
let family_of_gen_family base (genfam, gen_couple, gen_descend) =
let fevents = genfam.Def.fevents in
let witness_notes =
Some
(List.map
(fun fe ->
Array.map (fun (_, _, wnote) -> wnote) fe.Def.efam_witnesses)
fevents
|> Array.of_list)
in
let genfam = Translate.as_legacy_family genfam in
let family = family_of_gen_family base (genfam, gen_couple, gen_descend) in
{ family; base; witness_notes }
let no_family ifam =
let nof = no_family ifam in
Translate.legacy_to_def_family empty_string nof
let patch_family base ifam genfam =
let fevents = genfam.Def.fevents in
let genfam = Translate.as_legacy_family genfam in
patch_family base ifam genfam;
let witnotes = fwitness_notes_of_events fevents in
PatchFam.set base ifam witnotes;
clear_foi ifam
let insert_family base ifam genfam =
let fevents = genfam.Def.fevents in
let genfam = Translate.as_legacy_family genfam in
insert_family base ifam genfam;
let witnotes = fwitness_notes_of_events fevents in
PatchFam.set base ifam witnotes;
clear_foi ifam
let delete_family base ifam =
Gwdb_legacy.Gwdb_driver.delete_family base ifam;
clear_foi ifam
let get_children f = get_children f.family
let get_comment f = get_comment f.family
let get_divorce f = get_divorce f.family
let get_father f = get_father f.family
let get_fsources f = get_fsources f.family
let get_ifam f = get_ifam f.family
let get_marriage f = get_marriage f.family
let get_marriage_note f = get_marriage_note f.family
let get_marriage_place f = get_marriage_place f.family
let get_marriage_src f = get_marriage_src f.family
let get_mother f = get_mother f.family
let get_origin_file f = get_origin_file f.family
let get_parent_array f = get_parent_array f.family
let get_relation f = get_relation f.family
let get_witnesses f = get_witnesses f.family
let gen_couple_of_family f = gen_couple_of_family f.family
let gen_descend_of_family f = gen_descend_of_family f.family
let foi base ifam =
match find_foi ifam with
| Some f -> f
| None ->
let f = { family = foi base ifam; base; witness_notes = None } in
set_foi ifam f;
f
let families ?(select = fun _ -> true) base =
let select f = select { family = f; base; witness_notes = None } in
let coll = families ~select base in
Collection.map (fun family -> { family; base; witness_notes = None }) coll
let wrap_pid clear patch insert delete =
let patch b i d =
patch b i d;
clear i
in
let insert b i d =
insert b i d;
clear i
in
let delete b i =
delete b i;
clear i
in
(patch, insert, delete)
let wrap_iper_pid p i d = wrap_pid clear_poi p i d
let wrap_ifam_pid p i d = wrap_pid clear_foi p i d
let patch_ascend, insert_ascend, delete_ascend =
wrap_iper_pid patch_ascend insert_ascend delete_ascend
let patch_union, insert_union, delete_union =
wrap_iper_pid patch_union insert_union delete_union
let patch_descend, insert_descend, delete_descend =
wrap_ifam_pid patch_descend insert_descend delete_descend
let patch_couple, insert_couple, delete_couple =
wrap_ifam_pid patch_couple insert_couple delete_couple
let load_clear_array load clear =
let load_array base =
set_fpoi_cache base false;
load base
in
let clear_array base =
clear base;
set_fpoi_cache base true
in
(load_array, clear_array)
let load_ascends_array, clear_ascends_array =
load_clear_array load_ascends_array clear_ascends_array
let load_descends_array, clear_descends_array =
load_clear_array load_descends_array clear_descends_array
let load_unions_array, clear_unions_array =
load_clear_array load_unions_array clear_unions_array
let load_couples_array, clear_couples_array =
load_clear_array load_couples_array clear_couples_array
let close_base base =
close_base base;
PatchPer.close_data_file ();
PatchFam.close_data_file ();
clear_ascends_array base;
clear_unions_array base;
clear_couples_array base;
clear_descends_array base;
clear_strings_array base;
clear_persons_array base;
clear_families_array base;
PatchPer.empty ();
PatchFam.empty ();
()
end
module Driver = Compat.Make (Legacy_driver) (Legacy_driver)
include Driver

11
lib/gwdb/dune.in Normal file
View File

@@ -0,0 +1,11 @@
(library
(name geneweb_gwdb)
(public_name geneweb.gwdb)
(wrapped false)
(preprocess (action (run %{bin:cppo} %%%CPPO_D%%% -V OCAML:%{ocaml_version} %{input-file})))
(libraries unix
geneweb.def
geneweb.gwdb_driver
geneweb.util
)
)

298
lib/gwdb/gutil.ml Normal file
View File

@@ -0,0 +1,298 @@
(* Copyright (c) 1998-2007 INRIA *)
open Def
open Gwdb
let designation base p =
let first_name = p_first_name base p in
let nom = p_surname base p in
first_name ^ "." ^ string_of_int (get_occ p) ^ " " ^ nom
let father = Adef.father
let mother = Adef.mother
let couple multi fath moth =
if not multi then Adef.couple fath moth else Adef.multi_couple fath moth
let parent_array = Adef.parent_array
let spouse ip cpl =
if ip = get_father cpl then get_mother cpl else get_father cpl
let person_is_key base p k =
let k = Name.crush_lower k in
if k = Name.crush_lower (p_first_name base p ^ " " ^ p_surname base p) then
true
else if
List.exists
(fun x -> k = Name.crush_lower x)
(person_misc_names base p get_titles)
then true
else false
let find_num s i =
let rec loop start i =
if i = String.length s then None
else
match s.[i] with
| '0' .. '9' -> loop start (i + 1)
| c ->
if i = start then
if c = ' ' then loop (start + 1) (start + 1) else None
else Some (int_of_string (String.sub s start (i - start)), i)
in
loop i i
let split_key s i =
let rec loop i =
if i = String.length s then None
else if s.[i] = '.' then
match find_num s (i + 1) with
| Some (occ, j) ->
let first_name = String.sub s 0 i in
let surname = String.sub s j (String.length s - j) in
Some (i, first_name, occ, surname)
| None -> loop (i + 1)
else loop (i + 1)
in
loop i
let person_of_string_key base s =
let rec loop i =
match split_key s i with
| Some (i, first_name, occ, surname) -> (
match person_of_key base first_name surname occ with
| Some ip -> Some ip
| None -> loop (i + 1))
| None -> None
in
loop 0
let rsplit_key s =
let rec loop i =
if i = 0 then None
else if s.[i] = '.' then
match find_num s (i + 1) with
| Some (occ, j) ->
let first_name = String.sub s 0 i in
let surname = String.sub s j (String.length s - j) in
Some (first_name, occ, surname)
| None -> loop (i - 1)
else loop (i - 1)
in
loop (String.length s - 1)
let person_of_string_dot_key base s =
match rsplit_key s with
| Some (first_name, occ, surname) -> person_of_key base first_name surname occ
| None -> None
let person_not_a_key_find_all base s =
let ipl = persons_of_name base s in
let rec select = function
| ip :: ipl ->
if person_is_key base (poi base ip) s then
let ipl = select ipl in
if List.mem ip ipl then ipl else ip :: ipl
else select ipl
| [] -> []
in
select ipl
let person_ht_find_all base s =
match person_of_string_key base s with
| Some p -> [ p ]
| None -> person_not_a_key_find_all base s
let find_same_name base p =
let f = p_first_name base p in
let s = p_surname base p in
let ipl = person_ht_find_all base (f ^ " " ^ s) in
let f = Name.strip_lower f in
let s = Name.strip_lower s in
let pl =
List.fold_left
(fun pl ip ->
let p = poi base ip in
if
Name.strip_lower (p_first_name base p) = f
&& Name.strip_lower (p_surname base p) = s
then p :: pl
else pl)
[] ipl
in
List.sort (fun p1 p2 -> compare (get_occ p1) (get_occ p2)) pl
let trim_trailing_spaces s =
let len = String.length s in
let len' =
let rec loop i =
if i = -1 then 0
else
match String.unsafe_get s i with
| ' ' | '\r' | '\n' | '\t' -> loop (i - 1)
| _ -> i + 1
in
loop (len - 1)
in
if len' = 0 then "" else if len' = len then s else String.sub s 0 len'
let alphabetic_utf_8 n1 n2 =
let rec loop i1 i2 =
if i1 >= String.length n1 && i2 >= String.length n2 then i1 - i2
else if i1 >= String.length n1 then -1
else if i2 >= String.length n2 then 1
else
let cv1, ii1 = Name.unaccent_utf_8 false n1 i1 in
let cv2, ii2 = Name.unaccent_utf_8 false n2 i2 in
let c =
if cv1 = cv2 then
compare (String.sub n1 i1 (ii1 - i1)) (String.sub n2 i2 (ii2 - i2))
else compare cv1 cv2
in
if c = 0 then loop ii1 ii2 else c
in
if n1 = n2 then 0 else loop 0 0
let alphabetic_value =
let tab = Array.make 256 0 in
for i = 0 to 255 do
tab.(i) <- 10 * i
done;
tab.(Char.code '\xE0') <- (*'à'*) tab.(Char.code 'a') + 1;
tab.(Char.code '\xE1') <- (*'á'*) tab.(Char.code 'a') + 2;
tab.(Char.code '\xE2') <- (*'â'*) tab.(Char.code 'a') + 3;
tab.(Char.code '\xE8') <- (*'è'*) tab.(Char.code 'e') + 1;
tab.(Char.code '\xE9') <- (*'é'*) tab.(Char.code 'e') + 2;
tab.(Char.code '\xEA') <- (*'ê'*) tab.(Char.code 'e') + 3;
tab.(Char.code '\xEB') <- (*'ë'*) tab.(Char.code 'e') + 4;
tab.(Char.code '\xF4') <- (*'ô'*) tab.(Char.code 'o') + 1;
tab.(Char.code '\xC1') <- (*'Á'*) tab.(Char.code 'A') + 2;
tab.(Char.code '\xC6') <- (*'Æ'*) tab.(Char.code 'A') + 5;
tab.(Char.code '\xC8') <- (*'È'*) tab.(Char.code 'E') + 1;
tab.(Char.code '\xC9') <- (*'É'*) tab.(Char.code 'E') + 2;
tab.(Char.code '\xD6') <- (*'Ö'*) tab.(Char.code 'O') + 4;
tab.(Char.code '?') <- 3000;
fun x -> tab.(Char.code x)
let alphabetic_iso_8859_1 n1 n2 =
let rec loop i1 i2 =
if i1 = String.length n1 && i2 = String.length n2 then i1 - i2
else if i1 = String.length n1 then -1
else if i2 = String.length n2 then 1
else
let c1 = n1.[i1] in
let c2 = n2.[i2] in
if alphabetic_value c1 < alphabetic_value c2 then -1
else if alphabetic_value c1 > alphabetic_value c2 then 1
else loop (succ i1) (succ i2)
in
if n1 = n2 then 0 else loop (Mutil.initial n1) (Mutil.initial n2)
(* ??? *)
let alphabetic n1 n2 =
(*
if Mutil.utf_8_db.val then alphabetic_utf_8 n1 n2 else alphabetic_iso_8859_1 n1 n2
*)
alphabetic_iso_8859_1 n1 n2
let alphabetic_order n1 n2 = alphabetic_utf_8 n1 n2
let arg_list_of_string line =
let rec loop list i len quote =
if i = String.length line then
if len = 0 then List.rev list else List.rev (Buff.get len :: list)
else
match (quote, line.[i]) with
| Some c1, c2 ->
if c1 = c2 then loop list (i + 1) len None
else loop list (i + 1) (Buff.store len c2) quote
| None, ' ' ->
let list = if len = 0 then list else Buff.get len :: list in
loop list (i + 1) 0 quote
| None, (('"' | '\'') as c) -> loop list (i + 1) 0 (Some c)
| None, c -> loop list (i + 1) (Buff.store len c) None
in
loop [] 0 0 None
let sort_person_list_aux sort base =
let default p1 p2 =
match alphabetic (p_surname base p1) (p_surname base p2) with
| 0 -> (
match alphabetic (p_first_name base p1) (p_first_name base p2) with
| 0 -> (
match compare (get_occ p1) (get_occ p2) with
| 0 -> compare (get_iper p1) (get_iper p2)
| c -> c)
| c -> c)
| c -> c
in
sort (fun p1 p2 ->
if get_iper p1 = get_iper p2 then 0
else
match
match
( Date.od_of_cdate (get_birth p1),
get_death p1,
Date.od_of_cdate (get_birth p2),
get_death p2 )
with
| Some d1, _, Some d2, _ -> Date.compare_date d1 d2
| Some d1, _, _, Death (_, d2) ->
Date.compare_date d1 (Date.date_of_cdate d2)
| _, Death (_, d1), Some d2, _ ->
Date.compare_date (Date.date_of_cdate d1) d2
| _, Death (_, d1), _, Death (_, d2) ->
Date.compare_date (Date.date_of_cdate d1) (Date.date_of_cdate d2)
| Some _, _, _, _ -> 1
| _, Death (_, _), _, _ -> 1
| _, _, Some _, _ -> -1
| _, _, _, Death (_, _) -> -1
| _ -> 0
with
| 0 -> default p1 p2
| c -> c)
let sort_person_list = sort_person_list_aux List.sort
let sort_uniq_person_list = sort_person_list_aux List.sort_uniq
let find_free_occ base f s =
let ipl = persons_of_name base (f ^ " " ^ s) in
let first_name = Name.lower f in
let surname = Name.lower s in
let list_occ =
let rec loop list = function
| ip :: ipl ->
let p = poi base ip in
if
(not (List.mem (get_occ p) list))
&& first_name = Name.lower (p_first_name base p)
&& surname = Name.lower (p_surname base p)
then loop (get_occ p :: list) ipl
else loop list ipl
| [] -> list
in
loop [] ipl
in
let list_occ = List.sort compare list_occ in
let rec loop cnt1 = function
| cnt2 :: list -> if cnt1 = cnt2 then loop (cnt1 + 1) list else cnt1
| [] -> cnt1
in
loop 0 list_occ
let get_birth_death_date p =
let birth_date, approx =
match Date.od_of_cdate (get_birth p) with
| None -> (Date.od_of_cdate (get_baptism p), true)
| x -> (x, false)
in
let death_date, approx =
match Date.date_of_death (get_death p) with
| Some d -> (Some d, approx)
| None -> (
match get_burial p with
| Buried cd | Cremated cd -> (Date.od_of_cdate cd, true)
| UnknownBurial -> (None, approx))
in
(birth_date, death_date, approx)

85
lib/gwdb/gutil.mli Normal file
View File

@@ -0,0 +1,85 @@
(* Copyright (c) 1998-2007 INRIA *)
open Def
open Gwdb
val spouse : iper -> family -> iper
(** [spouse p f] returns spouse of giving person inside the family. *)
val person_not_a_key_find_all : base -> string -> iper list
(** Returns list of persons having the giving name as one of the misc names. *)
val person_ht_find_all : base -> string -> iper list
(** Returns list of persons from the giving key. If key has form {i "firstname.occ surname"}
then returns list of one corresponding person. Otherwise calls [person_not_a_key_find_all] *)
val person_of_string_key : base -> string -> iper option
(** [person_of_string_key base key]
Finds a key inside [key] string of the form {i "firstname.occ surname"}
and returns a corresponding person.
The first occurence of an int preceded by a dot is used as occurence number.
If person doesn't exists or key isn't found then returns [None] *)
val person_of_string_dot_key : base -> string -> iper option
(** [person_of_string_dot_key base key]
Same as {!val:person_of_string_key}, but use the last occurence
of an int preceded by a dot as occurence number. *)
val find_same_name : base -> person -> person list
(** Returns list of persons having the same first name and surname
as the specified person *)
val designation : base -> person -> string
(** Returns person's key that has form {i "firstname.occ surname"} *)
val trim_trailing_spaces : string -> string
(** Trim at the end of string *)
val alphabetic_utf_8 : string -> string -> int
(** Compare two UTF-8 encoded strings by alphabetic order *)
val alphabetic : string -> string -> int
(** Compare two ISO-8859-1 encoded strings by alphabetic order *)
val alphabetic_order : string -> string -> int
(** Same as [alphabetic_utf_8] *)
val arg_list_of_string : string -> string list
(** Parse line and extract separated arguments ("" and '' are used to indlude spaces
inside the argument) *)
val sort_person_list : base -> person list -> person list
(** Sort list of persons by comparison with following order:
- Compare by birth and death date
- Compare by surname
- Compare by first name
- Compare by occurence number
- Compare by id *)
val sort_uniq_person_list : base -> person list -> person list
(** Same as [sort_person_list] but also remove duplicates *)
val father : 'a gen_couple -> 'a
(** Same as [Adef.father] *)
val mother : 'a gen_couple -> 'a
(** Same as [Adef.mother] *)
val couple : bool -> 'a -> 'a -> 'a gen_couple
(** [couple multi f m] creates a couple from father [f] and mother [m]. If
[multi] true uses multiparent functionality *)
val parent_array : 'a gen_couple -> 'a array
(** Same as [Adef.parent_array] *)
val find_free_occ : base -> string -> string -> int
(** Find first free occurence number for the person with specified first name
and surname. *)
val get_birth_death_date : person -> date option * date option * bool
(** [get_birth_death p]
Return [(birth, death, approx)]. If birth/death date can not be found,
baptism/burial date is used and [approx] is set to [true] (it is [false]
if both birth and death dates are found).
*)

250
lib/gwdb/gwdb.ml Normal file
View File

@@ -0,0 +1,250 @@
open Def
include Gwdb_driver
(** [insert_person base p a u]
Add a new person with its union and ascendants in the [base].
Allocate and returns the fresh new id for this person.
[p] SHOULD be defined using [dummy_iper].
*)
let insert_person base p a u =
let iper = Gwdb_driver.new_iper base in
let p = { p with key_index = iper } in
Gwdb_driver.insert_ascend base iper a;
Gwdb_driver.insert_union base iper u;
Gwdb_driver.insert_person base iper p;
iper
(** [insert_family base f c d]
Add a new family with its couple and descendants the in the [base].
Allocate and returns the fresh new id for this family.
[f] SHOULD be defined using [dummy_ifam].
*)
let insert_family base f c d =
let ifam = Gwdb_driver.new_ifam base in
Gwdb_driver.insert_family base ifam f;
Gwdb_driver.insert_couple base ifam c;
Gwdb_driver.insert_descend base ifam d;
ifam
(** DELETE *)
let getp fn b i = fn @@ Gwdb_driver.poi b i
let get_gen_person = getp Gwdb_driver.gen_person_of_person
let get_gen_ascend = getp Gwdb_driver.gen_ascend_of_person
let get_gen_union = getp Gwdb_driver.gen_union_of_person
let getf fn b i = fn @@ Gwdb_driver.foi b i
let get_gen_family = getf Gwdb_driver.gen_family_of_family
let get_gen_couple = getf Gwdb_driver.gen_couple_of_family
let get_gen_descend = getf Gwdb_driver.gen_descend_of_family
let rec delete_person excl base ip =
let iexcl, fexcl = excl in
if ip = dummy_iper || List.mem ip iexcl then
failwith
("gwdb.delete_person(" ^ string_of_iper ip ^ ",["
^ (List.map string_of_iper iexcl |> String.concat ",")
^ "])");
let a = get_gen_ascend base ip in
(* if person is the single child and their parents are empty persons
then [ipers] contains father and mother and [ifams] contains family *)
let ipers, ifams =
match a.parents with
| Some ifam ->
(* delete ascendants *)
Gwdb_driver.delete_ascend base ip;
(* remove person id from family descendants *)
let children =
(get_gen_descend base ifam).children |> Mutil.array_except ip
in
Gwdb_driver.patch_descend base ifam { children };
if children = [| ip |] then
let c = get_gen_couple base ifam in
let fath = Adef.father c in
let moth = Adef.mother c in
if is_empty_p base fath ~ifam && is_empty_p base moth ~ifam then
([ fath; moth ], [ ifam ])
else ([], [])
else ([], [])
| None -> ([], [])
in
let del, ipers, ifams =
let u = get_gen_union base ip in
if u.family = [||] then (true, [], [])
else
Array.fold_left
(fun (del, ipers, ifams) ifam ->
let cpl = get_gen_couple base ifam in
(* Test if ip is really in union in order to prevent "false positive" *)
let fath = Adef.father cpl in
let moth = Adef.mother cpl in
if fath = ip || moth = ip then
let d = get_gen_descend base ifam in
if Array.length d.children > 1 then (false, ipers, ifams)
else
let sp = if ip = fath then moth else fath in
if List.mem sp iexcl then (del, ipers, ifams)
else if is_empty_p base sp ~ifam then
(del, sp :: ipers, ifam :: ifams)
else (false, ipers, ifams)
else (
(* Data are probably partially deleted.
It is likely to happen when merging persons. *)
rm_union base ifam ip;
(del, ipers, ifams)))
(true, ipers, ifams) u.family
in
if del then Gwdb_driver.delete_person base ip
else
Gwdb_driver.patch_person base ip
{ (no_person ip) with first_name = quest_string; surname = quest_string };
let iexcl = if del then ip :: iexcl else iexcl in
let excl = (iexcl, fexcl) in
let excl =
List.fold_left (fun excl ip -> delete_person excl base ip) excl ipers
in
List.fold_left (fun excl ifam -> delete_family excl base ifam) excl ifams
and is_empty_p ?ifam base sp =
(get_gen_ascend base sp).parents = None
&& ((get_gen_union base sp).family
= match ifam with Some i -> [| i |] | None -> [||])
&& get_gen_person base sp
= { (no_person sp) with first_name = quest_string; surname = quest_string }
and delete_family excl base ifam =
let iexcl, fexcl = excl in
if ifam = dummy_ifam || List.mem ifam fexcl then
failwith
("gwdb.delete_family(" ^ string_of_ifam ifam ^ ",["
^ (List.map string_of_ifam fexcl |> String.concat ",")
^ "])");
let fam = foi base ifam in
let fath = get_father fam in
let moth = get_mother fam in
let children = get_children fam in
rm_union base ifam fath;
rm_union base ifam moth;
Array.iter (fun i -> patch_ascend base i no_ascend) children;
Gwdb_driver.delete_family base ifam;
Gwdb_driver.delete_couple base ifam;
Gwdb_driver.delete_descend base ifam;
let fexcl = ifam :: fexcl in
let excl = (iexcl, fexcl) in
let excl =
if (not (List.mem fath iexcl)) && is_empty_p base fath then
delete_person excl base fath
else excl
in
let excl =
if (not (List.mem moth iexcl)) && is_empty_p base moth then
delete_person excl base moth
else excl
in
Array.fold_left
(fun excl i ->
if (not (List.mem i iexcl)) && is_empty_p base i then
delete_person excl base i
else excl)
excl children
and rm_union base ifam iper =
{ family = (get_gen_union base iper).family |> Mutil.array_except ifam }
|> patch_union base iper
(** [delete_person base iper] and [delete_family base ifam]
recursively delete data trying to do clever things:
- if data to be deleted is linked and useful,
it is replaced by empty data (and is actually deleted otherwise)
- if empty data is linked to deleted data, the former is deleted as well
*)
let delete_person base iper = ignore @@ delete_person ([], []) base iper
(** See {!val:delete_person} *)
let delete_family base ifam = ignore @@ delete_family ([], []) base ifam
(**/**)
(** Misc *)
(** [nobtitles base allowed_titles denied_titles p] returns list of titles of a person [p]
that apprears in [allowed_titles] and doesn't appears in [denied_titles]. If [allowed_titles]
is empty the every title is allowed *)
let nobtitles base allowed_titles denied_titles p =
let list = get_titles p in
match Lazy.force allowed_titles with
| [] -> list
| allowed_titles -> (
let list =
List.fold_right
(fun t l ->
let id = Name.lower (sou base t.t_ident) in
let pl = Name.lower (sou base t.t_place) in
if pl = "" then if List.mem id allowed_titles then t :: l else l
else if
List.mem (id ^ "/" ^ pl) allowed_titles
|| List.mem (id ^ "/*") allowed_titles
then t :: l
else l)
list []
in
match Lazy.force denied_titles with
| [] -> list
| denied_titles ->
List.filter
(fun t ->
let id = Name.lower (sou base t.t_ident) in
let pl = Name.lower (sou base t.t_place) in
if
List.mem (id ^ "/" ^ pl) denied_titles
|| List.mem ("*/" ^ pl) denied_titles
then false
else true)
list)
(** Returns first name of person *)
let p_first_name base p = Mutil.nominative (sou base (get_first_name p))
(** Returns surname of person *)
let p_surname base p = Mutil.nominative (sou base (get_surname p))
(** Returns array of surnames of person's husbands.
First element of a couple in the array is husband's surname,
second - is a husband's surname aliases *)
let husbands base gp =
let p = poi base gp.key_index in
Array.map
(fun ifam ->
let fam = foi base ifam in
let husband = poi base (get_father fam) in
let husband_surname = get_surname husband in
let husband_surnames_aliases = get_surnames_aliases husband in
(husband_surname, husband_surnames_aliases))
(get_family p)
(** Return person's father titles *)
let father_titles_places base p (nobtit : person -> title list) =
match get_parents (poi base p.key_index) with
| Some ifam ->
let fam = foi base ifam in
let fath = poi base (get_father fam) in
nobtit fath
| None -> []
let gen_gen_person_misc_names base p nobtit nobtit_fun =
Futil.gen_person_misc_names (sou base) empty_string quest_string p.first_name
p.surname p.public_name p.qualifiers p.aliases p.first_names_aliases
p.surnames_aliases nobtit
(if p.sex = Female then husbands base p else [||])
(father_titles_places base p nobtit_fun)
|> List.map Name.lower
(** [person_misc_names base p nobtit] computes various mix between all kind of names of a person's entry [p]
from the database [base]. [nobtit] is used to return a title entries for passed in argument person. *)
let person_misc_names base p nobtit =
gen_gen_person_misc_names base (gen_person_of_person p) (nobtit p) nobtit
(** Returns list of children ids for every family for giving person *)
let children_of_p base p =
Array.fold_right
(fun ifam -> Array.fold_right List.cons (get_children @@ foi base ifam))
(get_family p) []

6
lib/gwdb_driver.mli/dune Normal file
View File

@@ -0,0 +1,6 @@
(library
(name gwdb_driver_mli)
(public_name geneweb.gwdb_driver)
(wrapped false)
(libraries geneweb.def re)
(virtual_modules gwdb_driver))

668
lib/gwdb_driver.mli/gwdb_driver.mli Normal file
View File

@@ -0,0 +1,668 @@
(* Copyright (c) 1998-2007 INRIA *)
type istr
(** String id *)
type ifam
(** Family id *)
type iper
(** Person id *)
val string_of_iper : iper -> string
(** Convert [iper] to string *)
val string_of_ifam : ifam -> string
(** Convert [ifam] to string *)
val string_of_istr : istr -> string
(** Convert [istr] to string *)
val iper_of_string : string -> iper
(** Convert [iper] from string *)
val ifam_of_string : string -> ifam
(** Convert [ifam] from string *)
val istr_of_string : string -> istr
(** Convert [istr] from string *)
type person
(** Person data structure *)
type family
(** Family data structure *)
type relation = (iper, istr) Def.gen_relation
(** Database implementation for [Def.gen_relation] *)
type title = istr Def.gen_title
(** Database implementation for [Def.gen_title] *)
type pers_event = (iper, istr) Def.gen_pers_event
(** Database implementation for [Def.pers_event] *)
type fam_event = (iper, istr) Def.gen_fam_event
(** Database implementation for [Def.fam_event] *)
type string_person_index
(** Data structure for optimised search throughout index by name
(surname or first name). *)
type base
(** The database representation. *)
val open_base : string -> base
(** Open database associated with (likely situated in) the specified directory. *)
val close_base : base -> unit
(** Close database. May perform some clean up tasks. *)
val dummy_iper : iper
(** Dummy person id *)
val dummy_ifam : ifam
(** Dummy family id *)
val eq_istr : istr -> istr -> bool
(** [true] if strings with the giving ids are equal *)
val eq_ifam : ifam -> ifam -> bool
(** [true] if families with the giving ids are equal *)
val eq_iper : iper -> iper -> bool
(** [true] if persons with the giving ids are equal *)
val is_empty_string : istr -> bool
(** [true] if string with the giving id is empty ("") *)
val is_quest_string : istr -> bool
(** [true] if string with the giving id is a question mark ("?") *)
val empty_string : istr
(** Id of the empty string ("") *)
val quest_string : istr
(** Id of the question mark ("?") *)
val empty_person : base -> iper -> person
(** Returns unitialised person with the giving id. *)
val empty_family : base -> ifam -> family
(** Returns unitialised family with the giving id. *)
val iper_exists : base -> iper -> bool
(** Tells if person with giving id exists in the base. *)
val ifam_exists : base -> ifam -> bool
(** Tells if family with giving id exists in the base. *)
(** {2 Getters}
Getters are used to extract information about person and family.
If corresponding information part isn't present, driver load it from
the disk and cache it so further gets will return result immediately. *)
val get_access : person -> Def.access
(** Get privacy settings that define access to person's data *)
val get_aliases : person -> istr list
(** Get person's aliases ids *)
val get_baptism : person -> Def.cdate
(** Get person's baptism date *)
val get_baptism_note : person -> istr
(** Get person's baptism note id *)
val get_baptism_place : person -> istr
(** Get person's baptism place id *)
val get_baptism_src : person -> istr
(** Get person's baptism source id *)
val get_birth : person -> Def.cdate
(** Get person's birth date *)
val get_birth_note : person -> istr
(** Get person's birth note id *)
val get_birth_place : person -> istr
(** Get person's birth place id *)
val get_birth_src : person -> istr
(** Get person's birth source id *)
val get_burial : person -> Def.burial
(** Get information about person's burial *)
val get_burial_note : person -> istr
(** Get person's burial note id *)
val get_burial_place : person -> istr
(** Get person's burial place id *)
val get_burial_src : person -> istr
(** Get person's burial source id *)
val get_children : family -> iper array
(** Get array of family's children ids *)
val get_comment : family -> istr
(** Get family's comment (notes) id *)
val get_consang : person -> Adef.fix
(** Get person's consanguinity degree with his ascendants *)
val get_death : person -> Def.death
(** Get person's death status *)
val get_death_note : person -> istr
(** Get person's death note id *)
val get_death_place : person -> istr
(** Get person's death place id *)
val get_death_src : person -> istr
(** Get person's death source id *)
val get_divorce : family -> Def.divorce
(** Get family's divorce status *)
val get_family : person -> ifam array
(** Get array of family's ids to which a person belongs as parent (person's union) *)
val get_father : family -> iper
(** Get family's father id (from the family's couple) *)
val get_fevents : family -> fam_event list
(** Get family's event list *)
val get_first_name : person -> istr
(** Get person's first name id *)
val get_first_names_aliases : person -> istr list
(** Get list of person's first name aliases ids *)
val get_fsources : family -> istr
(** Get family's sources id *)
val get_ifam : family -> ifam
(** Get family's id *)
val get_image : person -> istr
(** Get id of path to person's image *)
val get_iper : person -> iper
(** Get person's id *)
val get_marriage : family -> Def.cdate
(** Get family's marriage date *)
val get_marriage_note : family -> istr
(** Get family's marriage note id *)
val get_marriage_place : family -> istr
(** Get family's marriage place id *)
val get_marriage_src : family -> istr
(** Get family's marriage source id *)
val get_mother : family -> iper
(** Get family's mother id (from the family's couple) *)
val get_notes : person -> istr
(** Get person's notes id *)
val get_occ : person -> int
(** Get person's occurence number *)
val get_occupation : person -> istr
(** Get person's occupation id *)
val get_origin_file : family -> istr
(** Get family's origin file (e.g. a .gw or .ged filename) id *)
val get_parent_array : family -> iper array
(** Get family's parents ids (father and mother from family's couple) *)
val get_parents : person -> ifam option
(** Get person's family id to which his parents belong (as family's couple) *)
val get_pevents : person -> pers_event list
(** Get person's event list *)
val get_psources : person -> istr
(** Get person's sources id *)
val get_public_name : person -> istr
(** Get person's public name id *)
val get_qualifiers : person -> istr list
(** Get list of person's qualifiers ids *)
val get_related : person -> iper list
(** Get person's related persons ids *)
val get_relation : family -> Def.relation_kind
(** Get relation kind between couple in the family *)
val get_rparents : person -> relation list
(** Get person's relations with not native parents *)
val get_sex : person -> Def.sex
(** Get person's sex *)
val get_surname : person -> istr
(** Get person's surname id *)
val get_surnames_aliases : person -> istr list
(** Get person's surname aliases ids *)
val get_titles : person -> title list
(** Get list of person's nobility titles *)
val get_witnesses : family -> iper array
(** Get array of family's witnesses ids *)
val gen_couple_of_family : family -> iper Def.gen_couple
(** Extract [gen_couple] from [family]. *)
val gen_descend_of_family : family -> iper Def.gen_descend
(** Extract [gen_descend] from [family]. *)
val gen_family_of_family : family -> (iper, ifam, istr) Def.gen_family
(** Extract [gen_family] from [family]. *)
val gen_person_of_person : person -> (iper, iper, istr) Def.gen_person
(** Extract [gen_person] from [person]. *)
val gen_ascend_of_person : person -> ifam Def.gen_ascend
(** Extract [gen_ascend] from [person]. *)
val gen_union_of_person : person -> ifam Def.gen_union
(** Extract [gen_union] from [person]. *)
val family_of_gen_family :
base ->
(iper, ifam, istr) Def.gen_family * iper Def.gen_couple * iper Def.gen_descend ->
family
(** Create [family] from associated values. *)
val person_of_gen_person :
base ->
(iper, iper, istr) Def.gen_person * ifam Def.gen_ascend * ifam Def.gen_union ->
person
(** Create [person] from associated values. *)
val poi : base -> iper -> person
(** Create uninitialised person with giving id *)
val foi : base -> ifam -> family
(** Create uninitialised family with giving id *)
val sou : base -> istr -> string
(** Returns string that has giving id from the base *)
val no_person : iper -> (iper, iper, istr) Def.gen_person
(** Returns unitialised [gen_person] with giving id *)
val no_ascend : ifam Def.gen_ascend
(** Returns unitialised [gen_ascend] *)
val no_union : ifam Def.gen_union
(** Returns unitialised [gen_union] *)
val no_family : ifam -> (iper, ifam, istr) Def.gen_family
(** Returns unitialised [gen_family] with giving id *)
val no_descend : iper Def.gen_descend
(** Returns unitialised [gen_descend] *)
val no_couple : iper Def.gen_couple
(** Returns unitialised [gen_couple] *)
val nb_of_persons : base -> int
(** Returns number of persons inside the database *)
val nb_of_real_persons : base -> int
(** Returns number of defined persons (without bogus definition "? ?")
inside the database *)
val nb_of_families : base -> int
(** Returns number of families inside the database *)
val bname : base -> string
(** Returns database name *)
val patch_person : base -> iper -> (iper, iper, istr) Def.gen_person -> unit
(** Modify/add person with the giving id in the base. New names are added
to the patched name index for the cosidered person and for evey member of family to
which he belongs. Modification stay blocked until call of [commit_patches]. *)
val patch_ascend : base -> iper -> ifam Def.gen_ascend -> unit
(** Modify/add ascendants of a person with a giving id. Modification stay blocked until
call of [commit_patches]. *)
val patch_union : base -> iper -> ifam Def.gen_union -> unit
(** Modify/add union of a person with a giving id. Modification stay blocked until
call of [commit_patches]. *)
val patch_family : base -> ifam -> (iper, ifam, istr) Def.gen_family -> unit
(** Modify/add family with a giving id. Modification stay blocked until
call of [commit_patches]. *)
val patch_descend : base -> ifam -> iper Def.gen_descend -> unit
(** Modify/add descendants of a family with a giving id. Modification stay blocked until
call of [commit_patches]. *)
val patch_couple : base -> ifam -> iper Def.gen_couple -> unit
(** Modify/add couple of a family with a giving id. Modification stay blocked until
call of [commit_patches]. *)
val insert_string : base -> string -> istr
(** Modify/add string with a giving id. If string already exists return its id.
Modification stay blocked until call of [commit_patches]. *)
val commit_patches : base -> unit
(** Commit blocked modifications (patches) and update database files in order to
apply modifications on the disk. *)
val commit_notes : base -> string -> string -> unit
(** [commit_notes fname s] Update content of the notes/extended page file [fname] if exists. *)
val new_iper : base -> iper
(** Retruns new unused person's id *)
val new_ifam : base -> ifam
(** Retruns new unused family's id *)
val insert_person : base -> iper -> (iper, iper, istr) Def.gen_person -> unit
(** Same as [patch_person] *)
val insert_ascend : base -> iper -> ifam Def.gen_ascend -> unit
(** Same as [patch_ascend] *)
val insert_union : base -> iper -> ifam Def.gen_union -> unit
(** Same as [patch_union] *)
val insert_family : base -> ifam -> (iper, ifam, istr) Def.gen_family -> unit
(** Same as [patch_family] *)
val insert_descend : base -> ifam -> iper Def.gen_descend -> unit
(** Same as [patch_couple] *)
val insert_couple : base -> ifam -> iper Def.gen_couple -> unit
(** Same as [patch_descend] *)
val delete_person : base -> iper -> unit
(** Remplace person with the giving id by bogus definition and clear
person's data structure. *)
val delete_ascend : base -> iper -> unit
(** Clear person's ascendants data structure *)
val delete_union : base -> iper -> unit
(** Clear person's union data structure *)
val delete_family : base -> ifam -> unit
(** Remplace family with the giving id by dummy family and clear
family's data structure. *)
val delete_descend : base -> ifam -> unit
(** Clear family's descendants data structure *)
val delete_couple : base -> ifam -> unit
(** Clear family's couple data structure *)
val person_of_key : base -> string -> string -> int -> iper option
(** [person_of_key first_name surname occ] returns person from his key information
(first name, surname and occurence number) *)
val persons_of_name : base -> string -> iper list
(** Return list of person ids that have giving name (could be one of the mix). *)
val persons_of_first_name : base -> string_person_index
(** Returns data structure that allows to make optimised search throughout
index by first name *)
val persons_of_surname : base -> string_person_index
(** Returns data structure that allows to make optimised search throughout
index by surname *)
val spi_first : string_person_index -> string -> istr
(** Returns first [first/sur]name id starting with that string *)
val spi_next : string_person_index -> istr -> istr
(** Retruns next [first/sur]name id that follows giving name's id by
Gutil.alphabetical order *)
val spi_find : string_person_index -> istr -> iper list
(** Retruns all persons id having that [first/sur]name. *)
val base_visible_get : base -> (person -> bool) -> iper -> bool
(** [base_visible_get base fct ip] get visibility of person [ip] ([true] for not visible
(restrited)) from the [base]. If file {i restrict} is present then read it to get
visibility information. If person's visibility isn't known, then set it with [fct].
Used when mode `use_restrict` is ativated *)
val base_visible_write : base -> unit
(** Write updated visibility information to the {i restricted} file. *)
val base_particles : base -> Re.re
(** Return regular expression that matches all defined in the [base] particles. *)
val base_strings_of_first_name : base -> string -> istr list
(** [base_strings_of_first_name base x]
Return the list of first names (as [istr]) being equal or to [x]
using {!val:Name.crush_lower} comparison. [x] could be also a substring
of the matched first name.
*)
val base_strings_of_surname : base -> string -> istr list
(** [base_strings_of_surname base x]
Return the list of surnames (as [istr]) being equal to [x]
using {!val:Name.crush_lower} comparison. [x] could be also a substring
of the matched surname.
*)
val load_ascends_array : base -> unit
(** Load array of ascendants in the memory and cache it so it could be accessed
instantly by other functions unless [clear_ascends_array] is called. *)
val load_unions_array : base -> unit
(** Load array of unions in the memory and cache it so it could be accessed
instantly by other functions unless [clear_unions_array] is called. *)
val load_couples_array : base -> unit
(** Load array of couples in the memory and cache it so it could be accessed
instantly by other functions unless [clear_couples_array] is called. *)
val load_descends_array : base -> unit
(** Load array of descendants in the memory and cache it so it could be accessed
instantly by other functions unless [clear_descends_array] is called. *)
val load_strings_array : base -> unit
(** Load array of strings in the memory and cache it so it could be accessed
instantly by other functions unless [clear_strings_array] is called. *)
val load_persons_array : base -> unit
(** Load array of persons in the memory and cache it so it could be accessed
instantly by other functions unless [clear_persons_array] is called. *)
val load_families_array : base -> unit
(** Load array of families in the memory and cache it so it could be accessed
instantly by other functions unless [clear_families_array] is called. *)
val clear_ascends_array : base -> unit
(** Remove array of ascendants from the memory *)
val clear_unions_array : base -> unit
(** Remove array of unions from the memory *)
val clear_couples_array : base -> unit
(** Remove array of couples from the memory *)
val clear_descends_array : base -> unit
(** Remove array of descendants from the memory *)
val clear_strings_array : base -> unit
(** Remove array of strings from the memory *)
val clear_persons_array : base -> unit
(** Remove array of persons from the memory *)
val clear_families_array : base -> unit
(** Remove array of families from the memory *)
val base_notes_read : base -> string -> string
(** [base_notes_read base fname] read and return content of [fname] note
(either database note either extended page). *)
val base_notes_read_first_line : base -> string -> string
(** [base_notes_read base fname] read and return first line of [fname] note *)
val base_notes_are_empty : base -> string -> bool
(** Says if note has empty content *)
val base_notes_origin_file : base -> string
(** Retruns origin file (.gw file) of the note *)
val base_notes_dir : base -> string
(** Directory where extended pages are stored *)
val base_wiznotes_dir : base -> string
(** Directory where wizard notes are stored *)
val date_of_last_change : base -> float
(** Returns last modification time of the database on disk *)
(** Collections of elemetns *)
module Collection : sig
type 'a t
(** Collections are sets of elements you want to traverse. *)
val length : 'a t -> int
(** Return the number of elements of a colletion *)
val map : ('a -> 'b) -> 'a t -> 'b t
(** [map fn c]
Return a collection corresponding to [c]
where [fn] would have been applied to each of its elements.
*)
val iter : ('a -> unit) -> 'a t -> unit
(** [iter fn c]
Apply [fn] would have been applied to each elements of [c].
*)
val iteri : (int -> 'a -> unit) -> 'a t -> unit
(** [iter fn c]
Apply [fn i] would have been applied to each elements of [c]
where [i] is the index (starting with 0) of the element.
*)
val fold : ?from:int -> ?until:int -> ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a
(** [fold fn acc c]
Combine each element of [c] into a single value using [fn].
[fn] first argument is the result computed so far as we traverse the
collection, and second element is the current element being combined.
[acc] is the starting combined value.
Start at [from]-nth and finish with [until]-nth element (included).
*)
val fold_until : ('a -> bool) -> ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a
(** [fold_until continue fn acc c]
Same as [fold fn acc c], but computation stops as soon as [continue]
is not satisfied by combined value anymore.
*)
val iterator : 'a t -> unit -> 'a option
(** [iterator c]
Return a function returning [Some next_element] when it is called,
or [None] if you reached the end of the collection.
*)
end
(** Markers for elements inside [Collection.t] *)
module Marker : sig
type ('k, 'v) t
(** Markers are way to annotate (add extra information to) elements of a {!val:Collection.t}. *)
val get : ('k, 'v) t -> 'k -> 'v
(** [get marker key]
Return the annotation associated to [key].
*)
val set : ('k, 'v) t -> 'k -> 'v -> unit
(** [set marker key value]
Set [value] as annotation associated to [key].
*)
end
(** {2 Useful collections} *)
val ipers : base -> iper Collection.t
(** Collection of person's ids *)
val persons : base -> person Collection.t
(** Collection of persons *)
val ifams : ?select:(ifam -> bool) -> base -> ifam Collection.t
(** Collection of family's ids *)
val families : ?select:(family -> bool) -> base -> family Collection.t
(** Collection of families *)
val dummy_collection : 'a -> 'a Collection.t
(** [dummy_collection x] create a dummy collection with no element.
[x] is only used for typing.
Useful for placeholders or for typing purpose. *)
(** {2 Useful markers} *)
val iper_marker : iper Collection.t -> 'a -> (iper, 'a) Marker.t
(** [iper_marker c v] create marker over collection of person's ids and initialise it
for every element with [v] *)
val ifam_marker : ifam Collection.t -> 'a -> (ifam, 'a) Marker.t
(** [ifam_marker c v] create marker over collection of family's ids and initialise it
for every element with [v] *)
val dummy_marker : 'a -> 'b -> ('a, 'b) Marker.t
(** [dummy_marker k v] create a dummy collection with no element.
[k] and [v] are only used for typing.
Useful for placeholders or for typing purpose. *)
(** {2 Database creation} *)
val make :
string ->
string list ->
((int, int, int) Def.gen_person array
* int Def.gen_ascend array
* int Def.gen_union array)
* ((int, int, int) Def.gen_family array
* int Def.gen_couple array
* int Def.gen_descend array)
* string array
* Def.base_notes ->
base
(** [make bname particles arrays] create a base with [bname] name and [arrays] as content. *)
val read_nldb : base -> (iper, ifam) Def.NLDB.t
(** TODOOCP : doc *)
val write_nldb : base -> (iper, ifam) Def.NLDB.t -> unit
val sync : ?scratch:bool -> base -> unit
(** [sync scratch base]
Ensure that everything is synced on disk.
Depending on the backend,
it may perform various operation such as indexes rebuilding,
and it might be a lengthy operation.
Use [scratch] (default false) to sync and rebuild
the whole database. Otherwise, only changes that occured
since the last [sync] call are treated.
*)

656
lib/history.ml Normal file
View File

@@ -0,0 +1,656 @@
(* $Id: history.ml,v 5.14 2007-09-12 09:58:44 ddr Exp $ *)
(* Copyright (c) 1998-2007 INRIA *)
open Config
open Def
open Gwdb
open TemplAst
open Util
(* S: Fail if conf.bname is undefined? *)
let file_name conf =
let bname =
if Filename.check_suffix conf.bname ".gwb" then conf.bname
else conf.bname ^ ".gwb"
in
Filename.concat (Util.bpath bname) "history"
(* Record history when committing updates *)
let ext_flags =
[ Open_wronly; Open_append; Open_creat; Open_text; Open_nonblock ]
(* ********************************************************************** *)
(* [Fonc] slash_name_of_key : string -> string -> int -> string *)
(* ********************************************************************** *)
(** [Description] : Renvoie la clé nom/prénom/occ.
[Args] :
- fn : string
- sn : string
- occ : int
[Retour] : string
[Rem] : Non exporté en clair hors de ce module. *)
let slash_name_of_key fn sn occ =
let space_to_unders = Mutil.tr ' ' '_' in
let fn = space_to_unders (Name.lower fn) in
let sn = space_to_unders (Name.lower sn) in
sn ^ "/" ^ fn ^ "/" ^ string_of_int occ
(* ********************************************************************** *)
(* [Fonc] diff_visibility :
config -> base -> gen_person -> gen_person -> string array *)
(* ********************************************************************** *)
(** [Description] : Si la visibilité de la personne a changé (entre
l'ancienne et la nouvelle), alors on revoie un tableau
avec la nouvelle visibilité.
[Args] :
- conf : configuration de la base
- base : base de donnée
- op : la person avant les modifications
- np : la person après les modifications
[Retour] : string array
[Rem] : Non exporté en clair hors de ce module. *)
let diff_visibility conf base op np =
let k = slash_name_of_key np.first_name np.surname np.occ in
let empty_union = { family = [||] } in
let empty_ascend = { parents = None; consang = Adef.fix (-1) } in
let op = Futil.map_person_ps (fun p -> p) (Gwdb.insert_string base) op in
let np = Futil.map_person_ps (fun p -> p) (Gwdb.insert_string base) np in
let o_p = Gwdb.person_of_gen_person base (op, empty_ascend, empty_union) in
let n_p = Gwdb.person_of_gen_person base (np, empty_ascend, empty_union) in
let tmp_conf = { conf with wizard = false; friend = false } in
let old_visibility = Util.authorized_age tmp_conf base o_p in
let new_visibility = Util.authorized_age tmp_conf base n_p in
if old_visibility <> new_visibility then
[| "VISIBLE"; k; string_of_bool new_visibility |]
else [||]
type kind_diff =
| Diff_person of
(iper, iper, string) gen_person * (iper, iper, string) gen_person
| Diff_string of (string * string * int) * (string * string * int)
(* ********************************************************************** *)
(* [Fonc] diff_key : gen_person -> gen_person -> string array *)
(* ********************************************************************** *)
(** [Description] : Si la clé de la personne a changé, alors on renvoie un
tableau avec l'ancienne clé et la nouvelle clé.
[Args] :
- op : la person avant les modifications
- np : la person après les modifications
[Retour] : string array
[Rem] : Non exporté en clair hors de ce module. *)
let diff_key d =
match d with
| Diff_person (op, np) ->
let o_key = slash_name_of_key op.first_name op.surname op.occ in
let n_key = slash_name_of_key np.first_name np.surname np.occ in
if o_key <> n_key then [| "KEY"; o_key; n_key |] else [||]
| Diff_string ((ofn, osn, oocc), (fn, sn, occ)) ->
let o_key = slash_name_of_key ofn osn oocc in
let n_key = slash_name_of_key fn sn occ in
if o_key <> n_key then [| "KEY"; o_key; n_key |] else [||]
(* ********************************************************************** *)
(* [Fonc] diff_person :
config -> base -> gen_person -> gen_person -> string array *)
(* ********************************************************************** *)
(** [Description] : Fonction qui ajouté des paramètres passés dans la
ligne de commande de notify_change. Elle permet de
savoir quelle genre de modifications ont été faites.
[Args] :
- conf : configuration de la base
- base : base de donnée
- op : la person avant les modifications
- np : la person après les modifications
[Retour] : string array
[Rem] : Non exporté en clair hors de ce module. *)
let diff_person conf base changed =
match changed with
| U_Add_person _ | U_Delete_person _ -> [||]
| U_Modify_person (o, n) ->
Array.append
(diff_key (Diff_person (o, n)))
(diff_visibility conf base o n)
| U_Merge_person (p1, p2, p) ->
let args_p1 =
Array.append
(diff_key (Diff_person (p1, p)))
(diff_visibility conf base p1 p)
in
let args_p2 =
Array.append
(diff_key (Diff_person (p2, p)))
(diff_visibility conf base p2 p)
in
Array.append args_p1 args_p2
| U_Send_image _ | U_Delete_image _
| U_Add_family (_, _)
| U_Modify_family (_, _, _)
| U_Delete_family (_, _)
| U_Invert_family (_, _)
| U_Merge_family (_, _, _, _)
| U_Add_parent (_, _) ->
[||]
| U_Change_children_name (_, l) ->
List.fold_left
(fun accu ((ofn, osn, oocc, _), (fn, sn, occ, _)) ->
Array.append accu
(diff_key (Diff_string ((ofn, osn, oocc), (fn, sn, occ)))))
[||] l
| U_Multi (o, n, _) -> diff_key (Diff_person (o, n))
| U_Notes (_, _) | U_Kill_ancestors _ -> [||]
(* ************************************************************************ *)
(* [Fonc] notify_change : config -> base -> base_changed -> string -> unit *)
(* ************************************************************************ *)
(** [Description] : Appel le script défini par la variable notify_change du
fichier gwf.
[Args] :
- conf : configuration de la base
- base : base de donnée
- changed : le type de modification (voir def.mli)
- action : le code du type de modification
[Retour] : Néant
[Rem] : Non exporté en clair hors de ce module. *)
let notify_change conf base changed action =
if Sys.unix then
match List.assoc_opt "notify_change" conf.base_env with
| Some comm -> (
let base_args =
match changed with
| U_Add_person p
| U_Modify_person (_, p)
| U_Delete_person p
| U_Merge_person (_, _, p)
| U_Send_image p
| U_Delete_image p
| U_Add_family (p, _)
| U_Modify_family (p, _, _)
| U_Delete_family (p, _)
| U_Invert_family (p, _)
| U_Merge_family (p, _, _, _)
| U_Add_parent (p, _)
| U_Kill_ancestors p
| U_Change_children_name (p, _)
| U_Multi (_, p, _) ->
let key = slash_name_of_key p.first_name p.surname p.occ in
[| key; string_of_iper p.key_index |]
| U_Notes (Some num, file) -> [| file; string_of_int num |]
| U_Notes (None, file) -> [| file |]
in
let optional_args = diff_person conf base changed in
let args = Array.append base_args optional_args in
let args =
Array.append [| comm; conf.bname; conf.user; action |] args
in
match Unix.fork () with
| 0 ->
if Unix.fork () <> 0 then exit 0
else (
(try Unix.execvp comm args with _ -> ());
exit 0)
| id -> ignore (Unix.waitpid [] id))
| None -> ()
(* ************************************************************************ *)
(* [Fonc] gen_record : config -> base -> base_changed -> string -> unit *)
(* ************************************************************************ *)
(** [Description] : Enregistre dans le fichier historique si la variable
"hitory" du fichier gwf est valorisée à "yes". Le fait qu'on ait des
gen_person, nous permet de pouvoir faire un diff entre avant et après
la modification d'une personne.
[Args] :
- conf : configuration de la base
- base : base de donnée
- changed : le type de modification (voir def.mli)
- action : le code du type de modification
[Retour] : Néant
[Rem] : Non exporté en clair hors de ce module. *)
let gen_record conf base changed action =
(match List.assoc_opt "history" conf.base_env with
| Some "yes" when not conf.manitou -> (
let item =
match changed with
| U_Add_person p
| U_Modify_person (_, p)
| U_Delete_person p
| U_Merge_person (_, _, p)
| U_Send_image p
| U_Delete_image p
| U_Add_family (p, _)
| U_Modify_family (p, _, _)
| U_Delete_family (p, _)
| U_Invert_family (p, _)
| U_Merge_family (p, _, _, _)
| U_Add_parent (p, _)
| U_Kill_ancestors p
| U_Change_children_name (p, _)
| U_Multi (_, p, _) ->
p.first_name ^ "." ^ string_of_int p.occ ^ " " ^ p.surname
| U_Notes (Some num, file) ->
let s = string_of_int num in
if file = "" then s else file ^ "/" ^ s
| U_Notes (None, file) -> file
in
let fname = file_name conf in
match
try Some (Secure.open_out_gen ext_flags 0o644 fname)
with Sys_error _ -> None
with
| Some oc ->
Printf.fprintf oc "%s [%s] %s %s\n"
(Util.sprintf_today conf :> string)
conf.user action item;
close_out oc
| None -> ())
| _ -> ());
HistoryDiff.record_diff conf base changed;
(* Effet de bord des modifications en masse : on peut facilement *)
(* créer 5000 nouveaux processus à chaque mise à jour. *)
(* Pour éviter cela, on n'appelle jamais notify_change lors de la *)
(* mise à jour de l'historique. *)
match changed with
| U_Multi (_, _, _) -> ()
| _ -> notify_change conf base changed action
(* ************************************************************************ *)
(* [Fonc] record : config -> base -> base_changed -> string -> unit *)
(* ************************************************************************ *)
(** [Description] : Suite à la mise à jour de la base, on réalise les
traitements suivant :
- mise à jour (si nécessaire) du fichier gwf pour le sosa_ref
- mise à jour du fichier historique
- appel du script notify_change
[Args] :
- conf : configuration de la base
- base : base de donnée
- changed : le type de modification (voir def.mli)
- action : le code du type de modification
[Retour] : Néant
[Rem] : Non exporté en clair hors de ce module. *)
let record conf base changed action =
(* Mise à jour du fichier gwf si le sosa_ref a changé. *)
(match changed with
| U_Modify_person (_, p) ->
let fn, sn, occ, ip = (p.first_name, p.surname, p.occ, p.key_index) in
update_gwf_sosa conf base (ip, (fn, sn, occ))
| U_Merge_person (p1, _, p) ->
let fn, sn, occ, ip = (p1.first_name, p1.surname, p1.occ, p1.key_index) in
update_gwf_sosa conf base (ip, (fn, sn, occ));
(* On n'a pas besoin de faire un update sur "p2" *)
(* parce qu'on le fait sur p dans tous les cas. *)
let fn, sn, occ, ip = (p.first_name, p.surname, p.occ, p.key_index) in
update_gwf_sosa conf base (ip, (fn, sn, occ))
| U_Change_children_name (_, l) ->
List.iter
(fun (_, (fn, sn, occ, ip)) ->
update_gwf_sosa conf base (ip, (fn, sn, occ)))
l
| _ -> ());
(* Mise à jour du fichier historique et appel de notify_change. *)
gen_record conf base changed action
(* ************************************************************************ *)
(* [Fonc] notify : config -> base -> string -> unit *)
(* ************************************************************************ *)
(** [Description] : Appel explicite de notify_change suite à une modification
de masse de la base (typiquement, le dico des lieux).
On évite comme ça la création de 5000 processus.
[Args] :
- conf : configuration de la base
- base : base de donnée
- action : le code du type de modification
[Retour] : Néant
[Rem] : Non exporté en clair hors de ce module. *)
let notify conf base action =
let empty_person = Gwdb.empty_person base Gwdb.dummy_iper in
let empty_person =
Util.string_gen_person base (gen_person_of_person empty_person)
in
notify_change conf base (U_Multi (empty_person, empty_person, false)) action
(* Request for history printing *)
let line_tpl = "0000-00-00 00:00:00 xx ."
let line_fields line =
if String.length line > String.length line_tpl then
let time = String.sub line 0 19 in
let user, i =
match (line.[20], String.index_opt line ']') with
| '[', Some i ->
let user = String.sub line 21 (i - 21) in
(user, i + 2)
| _ -> ("", 20)
in
let action = String.sub line i 2 in
let key =
let i = i + 3 in
if i >= String.length line then None
else Some (String.sub line i (String.length line - i))
in
Some (time, user, action, key)
else None
type hist_item = HI_notes of string * int option | HI_ind of person | HI_none
type 'a env =
| Vcnt of int ref
| Vinfo of string * string * string * hist_item * string
| Vpos of int ref
| Vsearch of (bool * string * int) option
| Vother of 'a
| Vnone
let get_env v env = try List.assoc v env with Not_found -> Vnone
let get_vother = function Vother x -> Some x | _ -> None
let set_vother x = Vother x
let possibly_highlight env s =
match get_env "search" env with
| Vsearch (Some (case_sens, h, _)) ->
if in_text case_sens h s then html_highlight case_sens h s else s
| _ -> s
let safe_val (s : Adef.safe_string) = VVstring (s :> string)
let rec eval_var conf base env _ _ = function
| [ "count" ] -> (
match get_env "count" env with
| Vcnt c -> VVstring (string_of_int !c)
| _ -> VVstring "")
| [ "first_name" ] -> (
match get_env "info" env with
| Vinfo (_, _, _, HI_ind p, _) -> VVstring (p_first_name base p)
| _ -> VVstring "")
| [ "found" ] -> (
match get_env "search" env with
| Vsearch (Some _) -> VVbool true
| _ -> VVbool false)
| [ "incr_count" ] -> (
match get_env "count" env with
| Vcnt c ->
incr c;
VVstring ""
| _ -> VVstring "")
| [ "is_note" ] -> (
match get_env "info" env with
| Vinfo (_, _, _, HI_notes (_, _), _) -> VVbool true
| _ -> VVbool false)
| [ "key" ] -> (
match get_env "info" env with
| Vinfo (_, _, _, _, s) -> VVstring (possibly_highlight env s)
| _ -> raise Not_found)
| "note" :: "page" :: sl -> (
match get_env "info" env with
| Vinfo (_, _, _, HI_notes (s, _), _) ->
let s =
match sl with
| [ "v" ] -> s
| [] -> possibly_highlight env s
| _ -> raise Not_found
in
VVstring s
| _ -> raise Not_found)
| [ "note"; "part" ] -> (
match get_env "info" env with
| Vinfo (_, _, _, HI_notes (_, Some x), _) -> VVstring (string_of_int x)
| Vinfo (_, _, _, HI_notes (_, None), _) -> VVstring ""
| _ -> raise Not_found)
| [ "occ" ] -> (
match get_env "info" env with
| Vinfo (_, _, _, HI_ind p, _) -> VVstring (string_of_int (get_occ p))
| _ -> VVstring "")
| "person" :: sl -> (
match get_env "info" env with
| Vinfo (_, _, _, HI_ind p, _) -> eval_person_field_var conf base env p sl
| _ -> raise Not_found)
| [ "pos" ] -> (
match get_env "pos" env with
| Vpos r -> VVstring (string_of_int !r)
| _ -> raise Not_found)
| [ "reset_count" ] -> (
match get_env "count" env with
| Vcnt c ->
c := 0;
VVstring ""
| _ -> VVstring "")
| [ "surname" ] -> (
match get_env "info" env with
| Vinfo (_, _, _, HI_ind p, _) -> VVstring (p_surname base p)
| _ -> VVstring "")
| [ "time" ] -> (
match get_env "info" env with
| Vinfo (s, _, _, _, _) -> VVstring (possibly_highlight env s)
| _ -> raise Not_found)
| "update" :: sl -> (
match get_env "info" env with
| Vinfo (_, u, _, _, _) -> eval_string u sl
| _ -> raise Not_found)
| "user" :: sl -> (
match get_env "info" env with
| Vinfo (_, _, s, _, _) ->
let s =
match sl with
| [ "v" ] -> s
| [] -> possibly_highlight env s
| _ -> raise Not_found
in
VVstring s
| _ -> raise Not_found)
| _ -> raise Not_found
and eval_string s = function
| [ "var" ] -> VVother (eval_string s)
| [] -> VVstring s
| _ -> raise Not_found
and eval_person_field_var conf base env p = function
| [ "access" ] -> safe_val (Util.acces conf base p :> Adef.safe_string)
| [ "dates" ] -> safe_val (DateDisplay.short_dates_text conf base p)
| [ "has_history" ] ->
let fn = sou base (get_first_name p) in
let sn = sou base (get_surname p) in
let occ = get_occ p in
let person_file = HistoryDiff.history_file fn sn occ in
VVbool (Sys.file_exists (HistoryDiff.history_path conf person_file))
| [ "history_file" ] ->
let fn = sou base (get_first_name p) in
let sn = sou base (get_surname p) in
let occ = get_occ p in
VVstring (HistoryDiff.history_file fn sn occ)
| [ "is_invisible" ] ->
let conf = { conf with wizard = false; friend = false } in
VVbool (not (Util.authorized_age conf base p))
| [ "title" ] -> safe_val (person_title conf base p)
| [] ->
VVstring
(possibly_highlight env
(simple_person_text conf base p : Adef.safe_string :> string))
| _ -> VVstring "person..."
and simple_person_text conf base p =
match main_title conf base p with
| Some t -> titled_person_text conf base p t
| None -> gen_person_text conf base p
let print_foreach conf base print_ast eval_expr =
let eval_int_expr env ep e =
let s = eval_expr env ep e in
try int_of_string s with Failure _ -> raise Not_found
in
let rec print_foreach env xx _ s sl el al =
match (s, sl) with
| "history_line", [] -> print_foreach_history_line env xx el al
| _, _ -> raise Not_found
and print_foreach_history_line env xx el al =
match
try Some (Secure.open_in_bin (file_name conf)) with Sys_error _ -> None
with
| Some ic -> (
try
let k, pos, wiz =
match el with
| [ [ e1 ]; [ e2 ]; [ e3 ] ] ->
let k = eval_int_expr env xx e1 in
let pos =
match get_env "search" env with
| Vsearch (Some (_, _, pos)) -> pos
| Vsearch None -> in_channel_length ic
| _ -> (
try eval_int_expr env xx e2
with Not_found -> in_channel_length ic)
in
let wiz = eval_expr env xx e3 in
(k, pos, wiz)
| [] -> (3, in_channel_length ic, "")
| _ -> raise Not_found
in
let pos =
let vv = (ref (Bytes.create 0), ref 0) in
let rec loop pos i =
if i >= k then pos
else
match
try Some (Mutil.rev_input_line ic pos vv)
with End_of_file -> None
with
| Some (line, pos) ->
let i = print_history_line2 env xx line wiz i al in
loop pos i
| None -> pos
in
loop pos 0
in
(match get_env "pos" env with Vpos r -> r := pos | _ -> ());
close_in ic
with e ->
close_in ic;
raise e)
| None -> ()
and print_history_line2 env xx line wiz i al =
match line_fields line with
| Some (time, user, action, keyo) ->
if wiz = "" || user = wiz then (
let hist_item =
match keyo with
| Some key -> (
match action with
| "mn" -> (
let i, j =
try
let i = String.rindex key '/' in
(i, i + 1)
with Not_found -> (0, 0)
in
let pg = String.sub key 0 i in
let s = String.sub key j (String.length key - j) in
try HI_notes (pg, Some (int_of_string s))
with Failure _ -> HI_notes (key, None))
| _ -> (
match Gutil.person_ht_find_all base key with
| [ ip ] -> HI_ind (pget conf base ip)
| _ -> HI_none))
| None -> HI_none
in
let not_displayed =
match hist_item with
| HI_ind p ->
is_hidden p
|| (is_hide_names conf p && not (authorized_age conf base p))
| _ -> false
in
if not_displayed then i
else
let key = match keyo with Some s -> s | None -> "" in
let env =
("info", Vinfo (time, action, user, hist_item, key)) :: env
in
List.iter (print_ast env xx) al;
i + 1)
else i
| None -> i
in
print_foreach
let gen_print conf base hoo =
let env =
let env = [ ("pos", Vpos (ref 0)); ("count", Vcnt (ref 0)) ] in
match hoo with Some ho -> ("search", Vsearch ho) :: env | None -> env
in
Hutil.interp conf "updhist"
{
Templ.eval_var = eval_var conf base;
Templ.eval_transl = (fun _ -> Templ.eval_transl conf);
Templ.eval_predefined_apply = (fun _ -> raise Not_found);
Templ.get_vother;
Templ.set_vother;
Templ.print_foreach = print_foreach conf base;
}
env ()
let print conf base = gen_print conf base None
(* searching *)
let search_text conf base s =
let s = if s = "" then " " else s in
let case_sens = p_getenv conf.env "c" = Some "on" in
let found =
match
try Some (Secure.open_in_bin (file_name conf)) with Sys_error _ -> None
with
| Some ic ->
let pos =
match p_getint conf.env "pos" with
| Some pos -> pos
| None -> in_channel_length ic
in
let vv = (ref (Bytes.create 0), ref 0) in
let rec loop pos =
match
try Some (Mutil.rev_input_line ic pos vv) with End_of_file -> None
with
| Some (line, pos2) -> (
match line_fields line with
| Some (time, user, _, keyo) ->
let key = match keyo with Some key -> key | None -> "" in
if
in_text case_sens s time || in_text case_sens s user
|| in_text case_sens s key
then Some pos
else loop pos2
| None -> None)
| None -> None
in
loop pos
| None -> None
in
let h =
match found with Some pos -> Some (case_sens, s, pos) | None -> None
in
gen_print conf base (Some h)
let print_search conf base =
if conf.wizard || conf.friend then
match try Some (List.assoc "s" conf.env) with Not_found -> None with
| Some s -> search_text conf base (Mutil.gen_decode false s)
| None -> print conf base
else print conf base

40
lib/history.mli Normal file
View File

@@ -0,0 +1,40 @@
(* $Id: history.mli,v 5.4 2007-01-19 01:53:16 ddr Exp $ *)
(* Copyright (c) 1998-2007 INRIA *)
open Config
open Def
open Gwdb
val file_name : config -> string
(** Returns path to the file where history of current base updates is stored *)
val record :
config -> base -> (iper, iper, ifam, string) base_changed -> string -> unit
(** [record conf change action] records new modification in the history files
(global file and specific for each concerned by modification person).
Additionally it does:
- Updates [conf.default_sosa_ref] if concered by modification person is referenced by default_sosa_ref
- Notify foreign {i notify_change} about modification on the base
(doesn't notify if multiple modifications are done succesively) *)
val notify : config -> base -> string -> unit
(** [notify conf base action]
Explicit notification of foreign script {i notify_change}
that modification action [action] was executed on the database.
Since [record] already does notify script about unary modification on the base,
this function is used exclusively to send notification about multiple
modifications and avoid creating indefinite amount of processes for each modification
(for example for each concerned person in the list of modified persons). *)
val print : config -> base -> unit
(** Displays an history of updates *)
val print_search : config -> base -> unit
(** Same as `print`, but simultaneously searches for text inside the history and higlhight all found matches.
Search pattern is available with {i s} variable in environement [conf.env]. *)
(* Useful stuff for who (i.e. plugins) wants to read history file. *)
val line_fields : string -> (string * string * string * string option) option
(** Parses one line of history file that delimits one modification record. *)

292
lib/historyDiff.ml Normal file
View File

@@ -0,0 +1,292 @@
(* Copyright (c) 1998-2007 INRIA *)
open Config
open Def
open Gwdb
type gen_record = {
date : Adef.safe_string;
wizard : Adef.safe_string;
gen_p : (iper, iper, string) gen_person;
gen_f : (iper, ifam, string) gen_family list;
gen_c : iper array list;
}
(* Le nom du fichier historique (à partir de la clé personne). *)
let history_file fn sn occ =
let space_to_unders = Mutil.tr ' ' '_' in
let f = space_to_unders (Name.lower fn) in
let s = space_to_unders (Name.lower sn) in
f ^ "." ^ string_of_int occ ^ "." ^ s
(* history directory path *)
let history_d conf =
let path =
match List.assoc_opt "history_path" conf.base_env with
| Some path when path <> "" -> path
| _ -> "history_d"
in
if Filename.is_relative path then
let bname =
if Filename.check_suffix conf.bname ".gwb" then conf.bname
else conf.bname ^ ".gwb"
in
Filename.concat (Util.bpath bname) path
else path
(* Le chemin du fichier historique dans le dossier history_d. *)
let history_path conf fname =
if String.length fname >= 6 then
let dirs =
[ history_d conf; String.make 1 fname.[0]; String.make 1 fname.[1] ]
in
List.fold_right Filename.concat dirs fname
else Filename.concat (history_d conf) fname
(* Créé tous les dossiers intermédiaires. *)
let create_history_dirs conf fname =
if String.length fname >= 6 then
let dirs =
[ history_d conf; String.make 1 fname.[0]; String.make 1 fname.[1] ]
in
Mutil.mkdir_p (List.fold_left Filename.concat "" dirs)
(* ************************************************************************ *)
(* [Fonc] write_history_file : config -> string -> gen_record -> unit *)
(* ************************************************************************ *)
(** [Description] : Enregistre la personne dans son fichier historique.
[Args] :
- fname : le chemin du fichier
- gr : le contenu de la personne
[Retour] : Néant
[Rem] : Non exporté en clair hors de ce module. *)
let write_history_file conf person_file fname gr =
(* On créé toujours les dossiers nécessaires (changement de clé ...). *)
let () = create_history_dirs conf person_file in
let ext_flags =
[ Open_wronly; Open_append; Open_creat; Open_binary; Open_nonblock ]
in
match
try Some (Secure.open_out_gen ext_flags 0o644 fname)
with Sys_error _ -> None
with
| Some oc ->
output_value oc (gr : gen_record);
close_out oc
| None -> ()
(* ************************************************************************ *)
(* [Fonc] make_gen_record :
config -> base -> bool -> gen_person -> gen_record *)
(* ************************************************************************ *)
(** [Description] : Crée un gen_record à partir d'une personne.
[Args] :
- conf : configuratino de la base
- base : base de donnée
- first : booléen pour savoir si c'est la première entrée de
l'historique. Si c'est le cas, on ne connait pas la date de
modification, donc on met "environ" une seconde avant.
- gen_p : gen_person
[Retour] :
- gen_record
[Rem] : Non exporté en clair hors de ce module. *)
let make_gen_record conf base first gen_p =
let date =
let conf =
(* On évite les calculs savant pour la date (ss - 1 avec une date *)
(* autour de minuit ...). C'est simplement une indication. *)
if first then
let hh, mm, ss = conf.time in
{ conf with time = (hh, mm, min 0 ss) }
else conf
in
Util.sprintf_today conf
in
let p = poi base gen_p.key_index in
let fam = get_family p in
(* On fait en sorte qu'il y a une 'bijection' *)
(* entre les familles et les enfants. *)
let gen_f, gen_c =
Array.fold_right
(fun ifam (accu_fam, accu_child) ->
let fam = foi base ifam in
let children = get_children fam in
let gen_f = gen_family_of_family fam in
(Util.string_gen_family base gen_f :: accu_fam, children :: accu_child))
fam ([], [])
in
{
date;
wizard = (Util.escape_html conf.user :> Adef.safe_string);
gen_p;
gen_f;
gen_c;
}
(* ************************************************************************ *)
(* [Fonc] record_diff : config -> base -> base_changed -> unit *)
(* ************************************************************************ *)
(** [Description] : Met à jour le fichier historique d'une personne.
[Args] :
- conf : configuration de la base
- base : base de donnée
- changed : le type de modification (voir def.mli)
[Retour] : Néant
[Rem] : Exporté en clair hors de ce module. *)
let record_diff conf base changed =
match List.assoc_opt "history_diff" conf.base_env with
| Some "yes" when not conf.manitou -> (
let print_ind_add p =
let person_file = history_file p.first_name p.surname p.occ in
let fname = history_path conf person_file in
let gr = make_gen_record conf base false p in
write_history_file conf person_file fname gr
in
let print_ind_mod o p =
let o_person_file = history_file o.first_name o.surname o.occ in
let person_file = history_file p.first_name p.surname p.occ in
let ofname = history_path conf o_person_file in
let fname = history_path conf person_file in
(* La clé a changé, on reprend l'ancien historique. *)
(if o_person_file <> person_file && Sys.file_exists ofname then
try
let () = create_history_dirs conf person_file in
Sys.rename ofname fname
with Sys_error _ -> ());
let gr = make_gen_record conf base false p in
if Sys.file_exists fname then
write_history_file conf person_file fname gr
else
let o_gr = make_gen_record conf base true o in
write_history_file conf person_file fname o_gr;
write_history_file conf person_file fname gr
in
match changed with
| U_Add_person p -> print_ind_add p
| U_Modify_person (o, p) -> print_ind_mod o p
| U_Delete_person _ -> ()
| U_Merge_person (_, o, p) ->
let o_person_file = history_file o.first_name o.surname o.occ in
let person_file = history_file p.first_name p.surname p.occ in
let fname = history_path conf person_file in
let gr = make_gen_record conf base false p in
(* La clé a changé avec la fusion, on reprend l'ancien historique. *)
if o_person_file <> person_file then (
let ofname = history_path conf o_person_file in
(try
let () = create_history_dirs conf person_file in
Sys.rename ofname fname
with Sys_error _ -> ());
write_history_file conf person_file fname gr)
else write_history_file conf person_file fname gr
| U_Delete_family (_p, _f) -> ()
| U_Add_family (p, f)
| U_Modify_family (p, _, f)
| U_Merge_family (p, _, _, f)
| U_Add_parent (p, f) ->
let p_file = history_file p.first_name p.surname p.occ in
let p_fname = history_path conf p_file in
let cpl = foi base f.fam_index in
let isp = Gutil.spouse p.key_index cpl in
let sp = poi base isp in
let sp_file =
history_file
(sou base (get_first_name sp))
(sou base (get_surname sp))
(get_occ sp)
in
let sp_fname = history_path conf sp_file in
let gen_sp = gen_person_of_person sp in
let gen_sp = Util.string_gen_person base gen_sp in
let gr = make_gen_record conf base false p in
write_history_file conf p_file p_fname gr;
let gr = make_gen_record conf base false gen_sp in
write_history_file conf sp_file sp_fname gr;
(* Création des fichiers pour les enfants ajoutés. *)
Array.iter
(fun ip ->
let p = poi base ip in
let person_file =
history_file
(sou base (get_first_name p))
(sou base (get_surname p))
(get_occ p)
in
let fname = history_path conf person_file in
if Sys.file_exists fname then ()
else
let gen_p = gen_person_of_person p in
let gen_p = Util.string_gen_person base gen_p in
let gr = make_gen_record conf base false gen_p in
write_history_file conf person_file fname gr)
(get_children cpl)
| U_Change_children_name (_, list) ->
List.iter
(fun ((ofn, osn, oocc, _oip), (fn, sn, occ, ip)) ->
let o_person_file = history_file ofn osn oocc in
let person_file = history_file fn sn occ in
if o_person_file <> person_file then (
let ofname = history_path conf o_person_file in
let fname = history_path conf person_file in
(try Sys.rename ofname fname with Sys_error _ -> ());
let p = poi base ip in
let p =
Futil.map_person_ps
(fun p -> p)
(sou base) (gen_person_of_person p)
in
let gr = make_gen_record conf base false p in
write_history_file conf person_file fname gr))
list
| U_Multi (o, p, modified_key) ->
if modified_key then print_ind_mod o p else print_ind_add p
| _ -> ())
| _ -> ()
(* avec zip ? *)
(*
let history = ref [] in
let fname = history_path conf fname in
if extract_zfile fname then
do {
read_history_file fname
Sys.remove fname
}
else ();
history.val
*)
(* ************************************************************************ *)
(* [Fonc] load_person_history : config -> string -> gen_record list *)
(* ************************************************************************ *)
(** [Description] : Charge la liste des modifications pour une personne.
L'avantage est que les versions les plus récentes se trouvent en
tête de liste.
[Args] :
- conf : configuration de la base
- fname : le nom du fichier historique
[Retour] :
- gen_record list
[Rem] : Non exporté en clair hors de ce module. *)
let load_person_history conf fname =
let history = ref [] in
let fname = history_path conf fname in
(match try Some (Secure.open_in_bin fname) with Sys_error _ -> None with
| Some ic ->
(try
while true do
let v : gen_record = input_value ic in
history := v :: !history
done
with End_of_file -> ());
close_in ic
| None -> ());
!history

27
lib/historyDiff.mli Normal file
View File

@@ -0,0 +1,27 @@
type gen_record = {
date : Adef.safe_string;
wizard : Adef.safe_string;
gen_p : (Gwdb.iper, Gwdb.iper, string) Def.gen_person;
gen_f : (Gwdb.iper, Gwdb.ifam, string) Def.gen_family list;
gen_c : Gwdb.iper array list;
}
(** Type that represents one update record stored in the history file for concerned person. *)
val history_file : string -> string -> int -> string
(** Returns history filename for the person with the given key.
Has format : {i firstname.occ.surname} *)
val history_path : Config.config -> string -> string
(** Returns path to the history file inside {i history_d} with given filename *)
val record_diff :
Config.config ->
Gwdb.base ->
(Gwdb.iper, Gwdb.iper, Gwdb.ifam, string) Def.base_changed ->
unit
(** [record_diff conf base change] records new updated information [change]
inside the history files of concerned by [change] persons. *)
val load_person_history : Config.config -> string -> gen_record list
(** Load list of modification records for a giving person's history file.
The most recent modification is at the head of the list *)

961
lib/historyDiffDisplay.ml Normal file
View File

@@ -0,0 +1,961 @@
(* Copyright (c) 1998-2007 INRIA *)
open Config
open Def
open Gwdb
open TemplAst
open Util
open HistoryDiff
let escape_html s = (Util.escape_html s :> Adef.safe_string)
let print_clean conf =
match p_getenv conf.env "f" with
| Some f when f <> "" ->
let title _ =
transl conf "clean history"
|> Utf8.capitalize_fst |> Output.print_sstring conf
in
Hutil.header conf title;
Hutil.print_link_to_welcome conf true;
Util.gen_print_tips conf
("select the input you want to erase from the history" |> transl conf
|> Utf8.capitalize_fst |> Adef.safe);
let history = load_person_history conf f in
Output.print_sstring conf {|<form method="post" action="|};
Output.print_sstring conf conf.command;
Output.print_sstring conf "\">";
Util.hidden_input conf "m" ("HIST_CLEAN_OK" |> Adef.encoded);
Util.hidden_input conf "f" (Mutil.encode f);
Output.print_sstring conf "<ul>";
let rec loop i = function
| [] -> ()
| gr :: l ->
Output.print_sstring conf "<li><label>";
Output.print_sstring conf {|<input type="checkbox" name="i|};
Output.print_sstring conf (string_of_int i);
Output.print_sstring conf {|" value="on">|};
Output.print_string conf gr.date;
Output.print_sstring conf {| |};
Output.print_string conf gr.HistoryDiff.wizard;
Output.print_sstring conf "</label></li>";
loop (i + 1) l
in
loop 0 history;
Output.print_sstring conf
{|</ul><button type="submit" class="btn btn-primary btn-lg">|};
transl_nth conf "validate/delete" 0
|> Utf8.capitalize_fst |> Output.print_sstring conf;
Output.print_sstring conf "</button></form>";
Hutil.trailer conf
| _ -> Hutil.incorrect_request conf
(* ************************************************************************ *)
(* [Fonc] print_clean_ok : config -> unit *)
(* ************************************************************************ *)
(** [Description] : Ré-écrit le fichier historique lié à une personne en
ayant supprimé les entrées non désirées.
[Args] :
- conf : configuration de la base
[Retour] : Néant
[Rem] : Exporté en clair hors de ce module. *)
let print_clean_ok conf =
let rec clean_history i history new_history =
match history with
| [] -> new_history
| gr :: l ->
let lab = "i" ^ string_of_int i in
if p_getenv conf.env lab = Some "on" then
clean_history (i + 1) l new_history
else clean_history (i + 1) l (gr :: new_history)
in
match p_getenv conf.env "f" with
| Some f when f <> "" ->
let title _ =
transl conf "history cleaned"
|> Utf8.capitalize_fst |> Output.print_sstring conf
in
Hutil.header conf title;
Hutil.print_link_to_welcome conf true;
let history = load_person_history conf f in
let new_history = clean_history 0 history [] in
let fname = history_path conf f in
(if new_history = [] then Mutil.rm fname
else
let ext_flags =
[ Open_wronly; Open_trunc; Open_creat; Open_binary; Open_nonblock ]
in
match
try Some (Secure.open_out_gen ext_flags 0o644 fname)
with Sys_error _ -> None
with
| Some oc ->
List.iter (fun v -> output_value oc (v : gen_record)) new_history;
close_out oc
| None -> ());
Hutil.trailer conf
| _ -> Hutil.incorrect_request conf
(**/**) (* Template *)
let person_of_gen_p_key base gen_p =
match person_of_key base gen_p.first_name gen_p.surname gen_p.occ with
| Some ip -> poi base ip
| None -> Gwdb.empty_person base Gwdb.dummy_iper
(* N'est pas forcément très précis. En effet, on enregistre que *)
(* les ipers. Or lors d'un nettoyage de la base, il se peut que *)
(* ces ipers changent. On peut donc pointer vers une autre persone. *)
let person_of_iper conf base ip =
try
let p = pget conf base ip in
if authorized_age conf base p then gen_person_text conf base p
else Adef.safe ""
with _ -> Adef.safe ""
let person_of_iper_array conf base ipl =
(Array.fold_right
(fun ip acc ->
let x = person_of_iper conf base ip in
if (x :> string) = "" then acc else x :: acc)
ipl []
: Adef.safe_string list
:> string list)
|> String.concat ", " |> Adef.safe
let string_of_cdate conf cod =
match Date.od_of_cdate cod with
| Some d -> DateDisplay.string_slash_of_date conf d
| None -> Adef.safe ""
let string_of_death conf death =
match Date.date_of_death death with
| Some cd -> DateDisplay.string_slash_of_date conf cd
| None -> Adef.safe ""
let string_of_burial conf burial =
match burial with
| Buried cod | Cremated cod -> string_of_cdate conf cod
| UnknownBurial -> Adef.safe ""
let string_of_title conf titles : Adef.safe_string =
let string_of_t_name t =
match t.t_name with Tname s -> escape_html s | _ -> Adef.safe ""
in
let one_title t =
let name = escape_html (t.t_ident ^ " " ^ t.t_place) in
let name = if (name :> string) = " " then Adef.safe "" else name in
let dates =
string_of_cdate conf t.t_date_start
^^^ "-"
^<^ string_of_cdate conf t.t_date_end
in
let dates =
if (dates :> string) = "-" then Adef.safe "" else "(" ^<^ dates ^>^ ")"
in
let nth =
let t_name = string_of_t_name t in
if (t_name :> string) = "" then
Adef.safe (if t.t_nth = 0 then "" else string_of_int t.t_nth)
else t_name ^>^ " " ^ string_of_int t.t_nth
in
let nth =
if (nth :> string) = "" then Adef.safe "" else "[" ^<^ nth ^>^ "]"
in
name
^^^ (if (name :> string) = "" then "" else " ")
^<^ nth
^^^ (if (nth :> string) = "" then "" else " ")
^<^ dates
in
List.fold_left
(fun (acc : Adef.safe_string) t ->
if (acc :> string) = "" then one_title t else acc ^^^ ", " ^<^ one_title t)
(Adef.safe "") titles
let string_of_related conf base ip related : Adef.safe_string =
List.fold_right
(fun ic acc ->
let p = person_of_iper conf base ip in
if (p :> string) = "" then acc
else
let c = try pget conf base ic with _ -> Gwdb.empty_person base ic in
let rel =
let rec loop rp =
match rp with
| [] -> Adef.safe ""
| r :: l -> (
match r.r_fath with
| Some ifath when ifath = ip ->
Util.rchild_type_text conf r.r_type 2
| _ -> loop l)
in
loop (get_rparents c)
in
(Utf8.capitalize_fst (rel : Adef.safe_string :> string)
^<^ transl conf ":" ^<^ p)
:: acc)
related []
|> (fun s -> String.concat ", " (s :> string list))
|> Adef.safe
let string_of_rparents conf base rparents : Adef.safe_string =
List.fold_right
(fun rp accu ->
match (rp.r_fath, rp.r_moth) with
| Some ip1, Some ip2 -> (
let rel =
(Util.relation_type_text conf rp.r_type 2
: Adef.safe_string
:> string)
|> Utf8.capitalize_fst
in
let fath = person_of_iper conf base ip1 in
let moth = person_of_iper conf base ip2 in
match ((fath :> string), (moth :> string)) with
| "", "" -> accu
| _, "" -> (rel ^<^ transl conf ":" ^<^ fath) :: accu
| "", _ -> (rel ^<^ transl conf ":" ^<^ moth) :: accu
| _, _ -> (rel ^<^ transl conf ":" ^<^ fath ^^^ ", " ^<^ moth) :: accu
)
| Some ip, None ->
let p = person_of_iper conf base ip in
if (p :> string) = "" then accu
else
(Utf8.capitalize_fst
(Util.relation_type_text conf rp.r_type 2
: Adef.safe_string
:> string)
^<^ transl conf ":" ^<^ p)
:: accu
| None, Some ip ->
let p = person_of_iper conf base ip in
if (p :> string) = "" then accu
else
(Utf8.capitalize_fst
(Util.relation_type_text conf rp.r_type 2
: Adef.safe_string
:> string)
^<^ transl conf ":" ^<^ p)
:: accu
| None, None -> accu)
rparents []
|> (fun s -> String.concat ", " (s : Adef.safe_string list :> string list))
|> Adef.safe
let string_of_marriage conf marriage =
let s =
match marriage with
| NotMarried | NoSexesCheckNotMarried -> "with"
| Married | NoSexesCheckMarried -> "married"
| Engaged -> "engaged"
| NoMention | MarriageBann | MarriageContract | MarriageLicense | Pacs
| Residence ->
"with"
in
Adef.safe (transl conf s)
let string_of_divorce conf divorce =
match divorce with
| NotDivorced -> "" |> Adef.safe
| Divorced cod -> transl conf "divorced" ^<^ " " ^<^ string_of_cdate conf cod
| Separated -> transl conf "separated" |> Adef.safe
let string_of_event_witness conf base witnesses =
Array.fold_right
(fun (ip, wk) accu ->
let witn = person_of_iper conf base ip in
let kind = Util.string_of_witness_kind conf (get_sex @@ poi base ip) wk in
if (witn :> string) = "" then (kind ^^^ transl conf ":" ^<^ witn) :: accu
else accu)
witnesses []
|> fun s ->
String.concat ", " (s : Adef.safe_string list :> string list) |> Adef.safe
let string_of_epers_name conf epers_name =
match epers_name with
| Epers_Birth -> Adef.safe @@ Utf8.capitalize_fst (transl conf "birth")
| Epers_Baptism -> Adef.safe @@ Utf8.capitalize_fst (transl conf "baptism")
| Epers_Death -> Adef.safe @@ Utf8.capitalize_fst (transl conf "death")
| Epers_Burial -> Adef.safe @@ Utf8.capitalize_fst (transl conf "burial")
| Epers_Cremation ->
Adef.safe @@ Utf8.capitalize_fst (transl conf "cremation")
| Epers_Accomplishment ->
Adef.safe @@ Utf8.capitalize_fst (transl conf "accomplishment")
| Epers_Acquisition ->
Adef.safe @@ Utf8.capitalize_fst (transl conf "acquisition")
| Epers_Adhesion -> Adef.safe @@ Utf8.capitalize_fst (transl conf "adhesion")
| Epers_BaptismLDS ->
Adef.safe @@ Utf8.capitalize_fst (transl conf "baptismLDS")
| Epers_BarMitzvah ->
Adef.safe @@ Utf8.capitalize_fst (transl conf "bar mitzvah")
| Epers_BatMitzvah ->
Adef.safe @@ Utf8.capitalize_fst (transl conf "bat mitzvah")
| Epers_Benediction ->
Adef.safe @@ Utf8.capitalize_fst (transl conf "benediction")
| Epers_ChangeName ->
Adef.safe @@ Utf8.capitalize_fst (transl conf "change name")
| Epers_Circumcision ->
Adef.safe @@ Utf8.capitalize_fst (transl conf "circumcision")
| Epers_Confirmation ->
Adef.safe @@ Utf8.capitalize_fst (transl conf "confirmation")
| Epers_ConfirmationLDS ->
Adef.safe @@ Utf8.capitalize_fst (transl conf "confirmation LDS")
| Epers_Decoration ->
Adef.safe @@ Utf8.capitalize_fst (transl conf "decoration")
| Epers_DemobilisationMilitaire ->
Adef.safe @@ Utf8.capitalize_fst (transl conf "demobilisationMilitaire")
| Epers_Diploma -> Adef.safe @@ Utf8.capitalize_fst (transl conf "diploma")
| Epers_Distinction ->
Adef.safe @@ Utf8.capitalize_fst (transl conf "distinction")
| Epers_Dotation -> Adef.safe @@ Utf8.capitalize_fst (transl conf "dotation")
| Epers_DotationLDS ->
Adef.safe @@ Utf8.capitalize_fst (transl conf "dotationLDS")
| Epers_Education ->
Adef.safe @@ Utf8.capitalize_fst (transl conf "education")
| Epers_Election -> Adef.safe @@ Utf8.capitalize_fst (transl conf "election")
| Epers_Emigration ->
Adef.safe @@ Utf8.capitalize_fst (transl conf "emigration")
| Epers_Excommunication ->
Adef.safe @@ Utf8.capitalize_fst (transl conf "excommunication")
| Epers_FamilyLinkLDS ->
Adef.safe @@ Utf8.capitalize_fst (transl conf "familyLinkLDS")
| Epers_FirstCommunion ->
Adef.safe @@ Utf8.capitalize_fst (transl conf "firstCommunion")
| Epers_Funeral -> Adef.safe @@ Utf8.capitalize_fst (transl conf "funeral")
| Epers_Graduate -> Adef.safe @@ Utf8.capitalize_fst (transl conf "graduate")
| Epers_Hospitalisation ->
Adef.safe @@ Utf8.capitalize_fst (transl conf "hospitalisation")
| Epers_Illness -> Adef.safe @@ Utf8.capitalize_fst (transl conf "illness")
| Epers_Immigration ->
Adef.safe @@ Utf8.capitalize_fst (transl conf "immigration")
| Epers_ListePassenger ->
Adef.safe @@ Utf8.capitalize_fst (transl conf "listePassenger")
| Epers_MilitaryDistinction ->
Adef.safe @@ Utf8.capitalize_fst (transl conf "militaryDistinction")
| Epers_MilitaryPromotion ->
Adef.safe @@ Utf8.capitalize_fst (transl conf "militaryPromotion")
| Epers_MilitaryService ->
Adef.safe @@ Utf8.capitalize_fst (transl conf "militaryService")
| Epers_MobilisationMilitaire ->
Adef.safe @@ Utf8.capitalize_fst (transl conf "mobilisationMilitaire")
| Epers_Naturalisation ->
Adef.safe @@ Utf8.capitalize_fst (transl conf "naturalisation")
| Epers_Occupation ->
Adef.safe
@@ Utf8.capitalize_fst (transl_nth conf "occupation/occupations" 0)
| Epers_Ordination ->
Adef.safe @@ Utf8.capitalize_fst (transl conf "ordination")
| Epers_Property -> Adef.safe @@ Utf8.capitalize_fst (transl conf "property")
| Epers_Recensement ->
Adef.safe @@ Utf8.capitalize_fst (transl conf "recensement")
| Epers_Residence ->
Adef.safe @@ Utf8.capitalize_fst (transl conf "residence")
| Epers_Retired -> Adef.safe @@ Utf8.capitalize_fst (transl conf "retired")
| Epers_ScellentChildLDS ->
Adef.safe @@ Utf8.capitalize_fst (transl conf "scellentChildLDS")
| Epers_ScellentParentLDS ->
Adef.safe @@ Utf8.capitalize_fst (transl conf "scellentParentLDS")
| Epers_ScellentSpouseLDS ->
Adef.safe @@ Utf8.capitalize_fst (transl conf "scellentSpouseLDS")
| Epers_VenteBien ->
Adef.safe @@ Utf8.capitalize_fst (transl conf "venteBien")
| Epers_Will -> Adef.safe @@ Utf8.capitalize_fst (transl conf "will")
| Epers_Name n ->
Adef.safe
@@ Utf8.capitalize_fst (escape_html n : Adef.safe_string :> string)
let string_of_efam_name conf efam_name =
match efam_name with
| Efam_Marriage ->
Adef.safe @@ Utf8.capitalize_fst (transl conf "marriage event")
| Efam_NoMarriage ->
Adef.safe @@ Utf8.capitalize_fst (transl conf "no marriage event")
| Efam_NoMention ->
Adef.safe @@ Utf8.capitalize_fst (transl conf "no mention")
| Efam_Engage -> Adef.safe @@ Utf8.capitalize_fst (transl conf "engage event")
| Efam_Divorce ->
Adef.safe @@ Utf8.capitalize_fst (transl conf "divorce event")
| Efam_Separated ->
Adef.safe @@ Utf8.capitalize_fst (transl conf "separate event")
| Efam_Annulation ->
Adef.safe @@ Utf8.capitalize_fst (transl conf "annulation")
| Efam_MarriageBann ->
Adef.safe @@ Utf8.capitalize_fst (transl conf "marriage bann")
| Efam_MarriageContract ->
Adef.safe @@ Utf8.capitalize_fst (transl conf "marriage contract")
| Efam_MarriageLicense ->
Adef.safe @@ Utf8.capitalize_fst (transl conf "marriage licence")
| Efam_PACS -> Adef.safe @@ Utf8.capitalize_fst (transl conf "PACS")
| Efam_Residence -> Adef.safe @@ Utf8.capitalize_fst (transl conf "residence")
| Efam_Name n ->
Adef.safe
@@ Utf8.capitalize_fst (escape_html n : Adef.safe_string :> string)
(* ************************************************************************ *)
(* [Fonc] highlight_diff : char array -> bool array -> string *)
(* ************************************************************************ *)
(** [Description] : Converti un tableau de char en string, avec les parties
modifiées encadrées par des balises <span>.
[Args] :
- arr : tableau à convertir
- diff_arr : tableau des différences
[Retour] :
- string
[Rem] : Non exporté en clair hors de ce module. *)
let highlight_diff arr diff_arr =
let rec loop i s =
if i >= Array.length arr then s
else if diff_arr.(i) then (
let j = ref i in
let accu = ref s in
accu := !accu ^ "<span class=\"mark\">";
while !j < Array.length diff_arr && diff_arr.(!j) do
accu := !accu ^ Printf.sprintf "%c" arr.(!j);
incr j
done;
accu := !accu ^ "</span>";
loop !j !accu)
else loop (i + 1) (s ^ Printf.sprintf "%c" arr.(i))
in
loop 0 ""
(* ************************************************************************ *)
(* [Fonc] array_of_string : string -> char array *)
(* ************************************************************************ *)
(** [Description] : Converti une string en tableau de char afin de pouvoir
faire un diff.
[Args] :
- s : string à convertir
[Retour] :
- char array
[Rem] : Non exporté en clair hors de ce module. *)
let array_of_string s =
let s = (s :> string) in
let len = String.length s in
let a = Array.make len ' ' in
let rec loop i =
if i = len then a
else (
a.(i) <- s.[i];
loop (i + 1))
in
loop 0
let diff_string (before : Adef.safe_string) (after : Adef.safe_string) :
Adef.safe_string * Adef.safe_string =
if before = after then (before, after)
else if (before :> string) = "" then
(before, "<span class=\"mark\">" ^<^ after ^>^ "</span>")
else if (after :> string) = "" then
("<span class=\"mark\">" ^<^ before ^>^ "</span>", after)
else
let aa = array_of_string (after :> string) in
let bb = array_of_string (before :> string) in
let bef_d, aft_d = Difference.f bb aa in
let bef_s = highlight_diff bb bef_d in
let aft_s = highlight_diff aa aft_d in
(Adef.safe bef_s, Adef.safe aft_s)
type 'a env =
| Vfam of
(iper, ifam, string) gen_family option
* (iper, ifam, string) gen_family option
* bool
| Vchild of iper array option * iper array option
| Vfevent of
(iper, string) gen_fam_event option
* (iper, string) gen_fam_event option
* bool
| Vpevent of
(iper, string) gen_pers_event option
* (iper, string) gen_pers_event option
| Vint of int
| Vstring of string
| Vother of 'a
| Vnone
let get_env v env = try List.assoc v env with Not_found -> Vnone
let get_vother = function Vother x -> Some x | _ -> None
let set_vother x = Vother x
let str_val x = VVstring x
let safe_val (x : Adef.safe_string) = VVstring (x :> string)
let rec eval_var conf base env (bef, aft, p_auth) _loc sl =
try eval_simple_var conf base env (bef, aft, p_auth) sl
with Not_found -> eval_compound_var conf base env (bef, aft, p_auth) sl
and eval_simple_var conf base env (bef, aft, p_auth) :
string list -> 'a expr_val = function
| [ s ] -> eval_simple_str_var conf base env (bef, aft, p_auth) s
| _ -> raise Not_found
and eval_compound_var conf base env (bef, aft, p_auth) sl : 'b expr_val =
let loop = function
| [ s ] -> eval_simple_str_var conf base env (bef, aft, p_auth) s
| [ "evar"; s ] -> (
match p_getenv conf.env s with
| Some s -> safe_val (escape_html s)
| None -> str_val "")
| "before" :: sl ->
fst (eval_gen_record conf base env (bef, aft, p_auth) sl)
| "after" :: sl -> snd (eval_gen_record conf base env (bef, aft, p_auth) sl)
| _ -> raise Not_found
in
loop sl
and eval_gen_record conf base env (bef, aft, p_auth) :
string list -> 'a expr_val * 'b expr_val = function
| [ "date" ] -> (safe_val bef.date, safe_val aft.date)
| [ "wizard" ] ->
(safe_val bef.HistoryDiff.wizard, safe_val aft.HistoryDiff.wizard)
| [ s ] -> eval_str_gen_record conf base env (bef, aft, p_auth) s
| _ -> raise Not_found
and eval_str_gen_record conf base env (bef, aft, p_auth) :
string -> 'a expr_val * 'b expr_val =
let diff_string a b =
let a, b = diff_string a b in
(safe_val a, safe_val b)
in
let aux g =
if p_auth then
diff_string (g bef :> Adef.safe_string) (g aft :> Adef.safe_string)
else (str_val "", str_val "")
in
let aux' m_auth bef aft f =
if p_auth && m_auth then
match (bef, aft) with
| Some b, Some a -> diff_string (f conf b) (f conf a)
| None, Some a -> (str_val "", safe_val (f conf a))
| Some b, None -> (safe_val (f conf b), str_val "")
| None, None -> (str_val "", str_val "")
else (str_val "", str_val "")
in
function
| "first_name" -> aux (fun x -> Util.escape_html x.gen_p.first_name)
| "surname" -> aux (fun x -> Util.escape_html x.gen_p.surname)
| "occ" -> aux (fun x -> Adef.safe @@ string_of_int x.gen_p.occ)
| "image" ->
if not conf.no_image then aux (fun x -> Util.escape_html x.gen_p.image)
else (str_val "", str_val "")
| "public_name" -> aux (fun x -> Util.escape_html x.gen_p.public_name)
| "qualifiers" ->
aux (fun x -> Util.escape_html @@ String.concat ", " x.gen_p.qualifiers)
| "aliases" ->
aux (fun x -> Util.escape_html @@ String.concat ", " x.gen_p.aliases)
| "first_names_aliases" ->
aux (fun x ->
Util.escape_html @@ String.concat ", " x.gen_p.first_names_aliases)
| "surnames_aliases" ->
aux (fun x ->
Util.escape_html @@ String.concat ", " x.gen_p.surnames_aliases)
| "titles" -> aux (fun x -> string_of_title conf x.gen_p.titles)
| "relations" ->
aux (fun x ->
let r =
string_of_related conf base x.gen_p.key_index x.gen_p.related
in
let rp = string_of_rparents conf base x.gen_p.rparents in
if (r :> string) = "" then rp else r ^^^ ". " ^<^ rp)
| "occupation" -> aux (fun x -> Util.safe_html x.gen_p.occupation)
| "sex" ->
aux (fun x ->
Util.index_of_sex x.gen_p.sex
|> transl_nth conf "male/female/neuter"
|> Adef.safe)
| "access" ->
aux (fun x ->
match x.gen_p.access with
| IfTitles -> transl_nth conf "iftitles/public/private" 0 |> Adef.safe
| Public -> transl_nth conf "iftitles/public/private" 1 |> Adef.safe
| Private -> transl_nth conf "iftitles/public/private" 2 |> Adef.safe)
| "birth" -> aux (fun x -> string_of_cdate conf x.gen_p.birth)
| "birth_place" -> aux (fun x -> Util.escape_html x.gen_p.birth_place)
| "birth_note" -> aux (fun x -> Util.escape_html x.gen_p.birth_note)
| "birth_src" -> aux (fun x -> Util.escape_html x.gen_p.birth_src)
| "baptism" -> aux (fun x -> string_of_cdate conf x.gen_p.baptism)
| "baptism_place" -> aux (fun x -> Util.escape_html x.gen_p.baptism_place)
| "baptism_note" -> aux (fun x -> Util.escape_html x.gen_p.baptism_note)
| "baptism_src" -> aux (fun x -> Util.escape_html x.gen_p.baptism_src)
| "death" -> aux (fun x -> string_of_death conf x.gen_p.death)
| "death_place" -> aux (fun x -> Util.escape_html x.gen_p.death_place)
| "death_note" -> aux (fun x -> Util.escape_html x.gen_p.death_note)
| "death_src" -> aux (fun x -> Util.escape_html x.gen_p.death_src)
| "burial" -> aux (fun x -> string_of_burial conf x.gen_p.burial)
| "burial_place" -> aux (fun x -> Util.escape_html x.gen_p.burial_place)
| "burial_note" -> aux (fun x -> Util.escape_html x.gen_p.burial_note)
| "burial_src" -> aux (fun x -> Util.escape_html x.gen_p.burial_src)
| "pevent_name" -> (
match get_env "pevent" env with
| Vpevent (bef, aft) ->
aux' true bef aft (fun conf x ->
string_of_epers_name conf x.epers_name)
| _ -> raise Not_found)
| "pevent_date" -> (
match get_env "pevent" env with
| Vpevent (bef, aft) ->
aux' true bef aft (fun conf x -> string_of_cdate conf x.epers_date)
| _ -> raise Not_found)
| "pevent_place" -> (
match get_env "pevent" env with
| Vpevent (bef, aft) ->
aux' true bef aft (fun _ x -> escape_html x.epers_place)
| _ -> raise Not_found)
| "pevent_note" -> (
match get_env "pevent" env with
| Vpevent (bef, aft) ->
aux' (not conf.no_note) bef aft (fun _ x -> escape_html x.epers_note)
| _ -> raise Not_found)
| "pevent_src" -> (
match get_env "pevent" env with
| Vpevent (bef, aft) ->
aux' true bef aft (fun _ x -> escape_html x.epers_src)
| _ -> raise Not_found)
| "pevent_witness" -> (
match get_env "pevent" env with
| Vpevent (bef, aft) ->
aux' true bef aft (fun conf x ->
string_of_event_witness conf base x.epers_witnesses)
| _ -> raise Not_found)
| "notes" ->
if not conf.no_note then aux (fun x -> Util.escape_html x.gen_p.notes)
else (str_val "", str_val "")
| "psources" -> aux (fun x -> Util.escape_html x.gen_p.psources)
| "spouse" -> (
match get_env "fam" env with
| Vfam (_f_bef, _f_aft, m_auth) ->
if m_auth then
(eval_string_env "spouse_bef" env, eval_string_env "spouse_aft" env)
else (str_val "", str_val "")
| _ -> raise Not_found)
| "marriage" -> (
match get_env "fam" env with
| Vfam (bef, aft, m_auth) ->
aux' m_auth bef aft (fun conf x -> string_of_cdate conf x.marriage)
| _ -> raise Not_found)
| "marriage_place" -> (
match get_env "fam" env with
| Vfam (bef, aft, m_auth) ->
aux' m_auth bef aft (fun _ x -> escape_html x.marriage_place)
| _ -> raise Not_found)
| "marriage_src" -> (
match get_env "fam" env with
| Vfam (bef, aft, m_auth) ->
aux' m_auth bef aft (fun _ x -> escape_html x.marriage_src)
| _ -> raise Not_found)
| "witnesses" -> (
match get_env "fam" env with
| Vfam (bef, aft, m_auth) ->
aux' m_auth bef aft (fun conf x ->
person_of_iper_array conf base x.witnesses)
| _ -> raise Not_found)
| "marriage_type" -> (
match get_env "fam" env with
| Vfam (bef, aft, m_auth) ->
aux' m_auth bef aft (fun conf x -> string_of_marriage conf x.relation)
| _ -> raise Not_found)
| "divorce" -> (
match get_env "fam" env with
| Vfam (bef, aft, m_auth) ->
aux' m_auth bef aft (fun conf x -> string_of_divorce conf x.divorce)
| _ -> raise Not_found)
| "fevent_name" -> (
match get_env "fevent" env with
| Vfevent (bef, aft, m_auth) ->
aux' m_auth bef aft (fun conf x ->
string_of_efam_name conf x.efam_name)
| _ -> raise Not_found)
| "fevent_date" -> (
match get_env "fevent" env with
| Vfevent (bef, aft, m_auth) ->
aux' m_auth bef aft (fun conf x -> string_of_cdate conf x.efam_date)
| _ -> raise Not_found)
| "fevent_place" -> (
match get_env "fevent" env with
| Vfevent (bef, aft, m_auth) ->
aux' m_auth bef aft (fun _ x -> escape_html x.efam_place)
| _ -> raise Not_found)
| "fevent_note" -> (
match get_env "fevent" env with
| Vfevent (bef, aft, m_auth) ->
aux' (m_auth && not conf.no_note) bef aft (fun _ x ->
escape_html x.efam_note)
| _ -> raise Not_found)
| "fevent_src" -> (
match get_env "fevent" env with
| Vfevent (bef, aft, m_auth) ->
aux' m_auth bef aft (fun _ x -> escape_html x.efam_src)
| _ -> raise Not_found)
| "fevent_witness" -> (
match get_env "fevent" env with
| Vfevent (bef, aft, m_auth) ->
aux' m_auth bef aft (fun conf x ->
string_of_event_witness conf base x.efam_witnesses)
| _ -> raise Not_found)
| "comment" -> (
match get_env "fam" env with
| Vfam (bef, aft, m_auth) ->
aux' (m_auth && not conf.no_note) bef aft (fun _ x ->
escape_html x.comment)
| _ -> raise Not_found)
| "origin_file" -> (
match get_env "fam" env with
| Vfam (bef, aft, m_auth) ->
aux' m_auth bef aft (fun _ x -> escape_html x.origin_file)
| _ -> raise Not_found)
| "fsources" -> (
match get_env "fam" env with
| Vfam (bef, aft, m_auth) ->
aux' m_auth bef aft (fun _ x -> escape_html x.fsources)
| _ -> raise Not_found)
| "children" -> (
match get_env "fam" env with
| Vfam (_, _, m_auth) ->
if m_auth then
match get_env "child" env with
| Vchild (bef, aft) ->
aux' true bef aft (fun conf -> person_of_iper_array conf base)
| _ -> raise Not_found
else (str_val "", str_val "")
| _ -> raise Not_found)
| _ -> raise Not_found
and eval_simple_str_var conf base env (bef, aft, p_auth) : string -> 'a expr_val
= function
| "acces" ->
person_of_gen_p_key base aft.gen_p
|> acces conf base
|> (safe_val :> Adef.escaped_string -> 'a expr_val)
| "date" -> eval_string_env "date" env
| "history_len" -> eval_int_env "history_len" env
| "line" -> eval_int_env "line" env
| "nb_families" ->
max (List.length bef.gen_f) (List.length aft.gen_f)
|> string_of_int |> str_val
| "person" ->
if p_auth then
person_of_gen_p_key base aft.gen_p
|> Util.gen_person_text conf base
|> safe_val
else eval_string_env "history_file" env
| "wizard" -> eval_string_env "wizard" env
| _ -> raise Not_found
and eval_string_env s env =
match get_env s env with
| Vstring s -> str_val s (* FIXME? *)
| _ -> raise Not_found
and eval_int_env s env =
match get_env s env with
| Vint i -> str_val (string_of_int i)
| _ -> raise Not_found
let print_foreach conf base print_ast _eval_expr =
let rec print_foreach env xx _loc s sl _el al =
match s :: sl with
| [ "family" ] -> print_foreach_family env xx al
| [ "fevent" ] -> print_foreach_fevent env xx al
| [ "pevent" ] -> print_foreach_pevent env xx al
| [ "history_line" ] -> print_foreach_history_line env xx al
| _ -> raise Not_found
and print_foreach_family env xx al =
let bef, aft, p_auth = xx in
let rec loop bef_f bef_c aft_f aft_c =
match (bef_f, aft_f) with
| [], [] -> ()
| [], gen_f :: l ->
let fam = foi base gen_f.fam_index in
let isp = Gutil.spouse aft.gen_p.key_index fam in
let sp = person_of_iper conf base isp in
let m_auth = authorized_age conf base (poi base isp) && p_auth in
let vfam = Vfam (None, Some gen_f, m_auth) in
let vchild, c =
match (bef_c, aft_c) with
| [], gen_c :: l -> (Vchild (None, Some gen_c), l)
| _ -> (* pas normal*) (Vchild (None, None), [])
in
let env =
("fam", vfam) :: ("spouse_bef", Vstring "")
:: ("spouse_aft", Vstring (sp :> string))
:: ("child", vchild) :: env
in
List.iter (print_ast env xx) al;
loop [] bef_c l c
| gen_f :: l, [] ->
let fam = foi base gen_f.fam_index in
let isp = Gutil.spouse aft.gen_p.key_index fam in
let sp = person_of_iper conf base isp in
let m_auth = authorized_age conf base (poi base isp) && p_auth in
let vfam = Vfam (Some gen_f, None, m_auth) in
let vchild, c =
match (bef_c, aft_c) with
| gen_c :: l, [] -> (Vchild (Some gen_c, None), l)
| _ -> (* pas normal*) (Vchild (None, None), [])
in
let env =
("fam", vfam)
:: ("spouse_bef", Vstring (sp :> string))
:: ("spouse_aft", Vstring "") :: ("child", vchild) :: env
in
List.iter (print_ast env xx) al;
loop l c [] aft_c
| gen_f1 :: l1, gen_f2 :: l2 ->
let fam = foi base gen_f2.fam_index in
let isp1 = Gutil.spouse bef.gen_p.key_index fam in
let isp2 = Gutil.spouse aft.gen_p.key_index fam in
let sp1 = person_of_iper conf base isp1 in
let sp2 = person_of_iper conf base isp2 in
let m_auth = authorized_age conf base (poi base isp2) && p_auth in
let vfam = Vfam (Some gen_f1, Some gen_f2, m_auth) in
let vchild, c1, c2 =
match (bef_c, aft_c) with
| gen_c1 :: l1, gen_c2 :: l2 ->
(Vchild (Some gen_c1, Some gen_c2), l1, l2)
| _ -> (* pas normal*) (Vchild (None, None), [], [])
in
let env =
("fam", vfam)
:: ("spouse_bef", Vstring (sp1 :> string))
:: ("spouse_aft", Vstring (sp2 :> string))
:: ("child", vchild) :: env
in
List.iter (print_ast env xx) al;
loop l1 c1 l2 c2
in
loop bef.gen_f bef.gen_c aft.gen_f aft.gen_c
and print_foreach_fevent env xx al =
let rec loop m_auth bef_fevents aft_fevents =
match (bef_fevents, aft_fevents) with
| [], [] -> ()
| [], aft_evt :: l ->
let env = ("fevent", Vfevent (None, Some aft_evt, m_auth)) :: env in
List.iter (print_ast env xx) al;
loop m_auth [] l
| bef_evt :: l, [] ->
let env = ("fevent", Vfevent (Some bef_evt, None, m_auth)) :: env in
List.iter (print_ast env xx) al;
loop m_auth l []
| bef_evt :: l1, aft_evt :: l2 ->
let env =
("fevent", Vfevent (Some bef_evt, Some aft_evt, m_auth)) :: env
in
List.iter (print_ast env xx) al;
loop m_auth l1 l2
in
match get_env "fam" env with
| Vfam (bef, aft, m_auth) -> (
match (bef, aft) with
| Some b, Some a -> loop m_auth b.fevents a.fevents
| None, Some a -> loop m_auth [] a.fevents
| Some b, None -> loop m_auth b.fevents []
| None, None -> ())
| _ -> ()
and print_foreach_pevent env xx al =
let bef, aft, _p_auth = xx in
let rec loop bef_pevents aft_pevents =
match (bef_pevents, aft_pevents) with
| [], [] -> ()
| [], aft_evt :: l ->
let env = ("pevent", Vpevent (None, Some aft_evt)) :: env in
List.iter (print_ast env xx) al;
loop [] l
| bef_evt :: l, [] ->
let env = ("pevent", Vpevent (Some bef_evt, None)) :: env in
List.iter (print_ast env xx) al;
loop l []
| bef_evt :: l1, aft_evt :: l2 ->
let env = ("pevent", Vpevent (Some bef_evt, Some aft_evt)) :: env in
List.iter (print_ast env xx) al;
loop l1 l2
in
loop bef.gen_p.pevents aft.gen_p.pevents
and print_foreach_history_line env xx al =
match get_env "history_file" env with
| Vstring fname ->
let history = load_person_history conf fname in
let rec loop i list =
match list with
| [] -> ()
| gr :: l ->
let env =
("line", Vint i)
:: ("date", Vstring (gr.date : Adef.safe_string :> string))
:: ( "wizard",
Vstring
(gr.HistoryDiff.wizard : Adef.safe_string :> string) )
:: env
in
List.iter (print_ast env xx) al;
loop (i + 1) l
in
loop 0 history
| _ -> ()
in
print_foreach
let eval_predefined_apply conf _env f vl =
let vl = List.map (function VVstring s -> s | _ -> raise Not_found) vl in
match (f, vl) with
| "transl_date", [ date_txt ] -> (
(* date_tpl = "0000-00-00 00:00:00" *)
try
let year = int_of_string (String.sub date_txt 0 4) in
let month = int_of_string (String.sub date_txt 5 2) in
let day = int_of_string (String.sub date_txt 8 2) in
let date =
Dgreg ({ day; month; year; prec = Sure; delta = 0 }, Dgregorian)
in
let time = String.sub date_txt 11 8 in
DateDisplay.string_of_date conf date ^>^ ", " ^ time
with Failure _ -> escape_html date_txt)
| _ -> raise Not_found
let print conf base =
match p_getenv conf.env "t" with
| Some ("SUM" | "DIFF") -> (
match p_getenv conf.env "f" with
| Some file when file <> "" ->
let history = load_person_history conf file in
let len = List.length history in
let before, after =
match (p_getint conf.env "old", p_getint conf.env "new") with
| Some o, Some n ->
let o =
if o < 0 then 0 else if o > len - 1 then len - 1 else o
in
let n =
if n < 0 then 0 else if n > len - 1 then len - 1 else n
in
(o, n)
| _ -> (0, 0)
in
let before = List.nth history before in
let after = List.nth history after in
let p = person_of_gen_p_key base after.gen_p in
let p_auth = authorized_age conf base p in
let env =
[ ("history_file", Vstring file); ("history_len", Vint len) ]
in
let eval_predefined_apply _env f vl =
(eval_predefined_apply conf _env f vl :> string)
in
Hutil.interp conf "updhist_diff"
{
Templ.eval_var = eval_var conf base;
Templ.eval_transl = (fun _ -> Templ.eval_transl conf);
Templ.eval_predefined_apply;
Templ.get_vother;
Templ.set_vother;
Templ.print_foreach = print_foreach conf base;
}
env (before, after, p_auth)
| _ -> Hutil.incorrect_request conf)
| _ -> Hutil.incorrect_request conf

9
lib/historyDiffDisplay.mli Normal file
View File

@@ -0,0 +1,9 @@
val print_clean : Config.config -> unit
(** Displays page that allows to select all revision of the history file in argument that user may want to clean *)
val print_clean_ok : Config.config -> unit
(** Cleans the history associated to the history file in argument *)
val print : Config.config -> Gwdb.base -> unit
(** Displays the page that allows to select (with variable {i t} = "SUM") and to view (with variable {i t} = "DIFF") the difference between all revisions of
history file of concerned person in variable {i f}. Intepretate the template file {i updhist_diff.txt} *)

281
lib/hutil.ml Normal file
View File

@@ -0,0 +1,281 @@
(* Copyright (c) 2007 INRIA *)
open Config
open Def
let link_to_referer conf =
let referer = Util.get_referer conf in
let back = Utf8.capitalize_fst (Util.transl conf "back") in
if (referer :> string) <> "" then
({|<a href="|} ^<^ referer
^>^ {|" class="btn btn-sm btn-link p-0 border-0" title="|} ^ back
^ {|"><i class="fa fa-arrow-left-long fa-fw fa-sm"></i></a>|}
:> Adef.safe_string)
else Adef.safe ""
let gen_print_link_to_welcome f conf _right_aligned =
Output.print_sstring conf "<div class=\"d-flex flex-column fix_top fix_left";
Output.print_sstring conf "\">\n";
f ();
Output.print_sstring conf {|<a href="|};
Output.print_string conf (Util.commd ~senv:false conf);
Output.print_sstring conf {|" title="|};
Output.print_sstring conf (Utf8.capitalize (Util.transl conf "home"));
Output.print_sstring conf {|"><i class="fa fa-house fa-fw fa-sm"></i></a>|};
let str = link_to_referer conf in
if (str :> string) <> "" then Output.print_string conf str;
Output.print_sstring conf "</div>"
let print_link_to_welcome = gen_print_link_to_welcome (fun () -> ())
(* S: use Util.include_template for "hed"? *)
let header_without_http_nor_home conf title =
let str1 =
Printf.sprintf {|<!DOCTYPE html>
<html lang="%s">
<head>
<title>|} conf.lang
in
let str2 =
Printf.sprintf
{|</title>
<meta name="robots" content="none">
<meta charset="%s">
<meta name="viewport" content="width=device-width, initial-scale=1, shrink-to-fit=no">
<link rel="shortcut icon" href="%s/favicon_gwd.png">
<link rel="apple-touch-icon" href="%s/favicon_gwd.png">
|}
conf.charset
(Util.images_prefix conf :> string)
(Util.images_prefix conf :> string)
in
Output.print_sstring conf str1;
title true;
Output.print_sstring conf str2;
Util.include_template conf [] "css" (fun () -> ());
Output.print_sstring conf "</head>\n";
let s =
try " dir=\"" ^ Hashtbl.find conf.lexicon "!dir" ^ "\""
with Not_found -> ""
in
let s = s ^ Util.body_prop conf in
Output.printf conf "<body%s>\n" s;
(match Util.open_etc_file conf "hed" with
| Some (ic, _) -> Templ.copy_from_templ conf [] ic
| None -> ());
Util.message_to_wizard conf
let header_without_page_title conf title =
Util.html conf;
header_without_http_nor_home conf title;
(* balancing </div> in gen_trailer *)
Output.printf conf "<div class=\"container\">"
let header_without_http conf title =
header_without_http_nor_home conf title;
match Util.open_etc_file conf "home" with
| Some (ic, _) -> Templ.copy_from_templ conf [] ic
| None -> ()
let header_link_welcome conf title =
header_without_page_title conf title;
Output.print_sstring conf "<h1>";
title false;
Output.print_sstring conf "</h1>\n"
let header_no_page_title conf title =
header_without_page_title conf title;
match Util.p_getenv conf.env "title" with
| None | Some "" -> ()
| Some x -> Output.printf conf "<h1>%s</h1>\n" x
let header conf title =
header_without_page_title conf title;
Output.print_sstring conf "\n<h1>";
title false;
Output.print_sstring conf "</h1>\n"
let header_fluid conf title =
header_without_http conf title;
(* balancing </div> in gen_trailer *)
Output.print_sstring conf "<div class=\"container-fluid\">";
Output.print_sstring conf "\n<h1>";
title false;
Output.print_sstring conf "</h1>\n"
let rheader conf title =
header_without_page_title conf title;
Output.print_sstring conf "<h1 class=\"error\">";
title false;
Output.print_sstring conf "</h1>\n"
let trailer conf =
let conf = { conf with is_printed_by_template = false } in
(match Util.open_etc_file conf "trl" with
| Some (ic, _) -> Templ.copy_from_templ conf [] ic
| None -> ());
Templ.print_copyright conf;
Util.include_template conf [] "js" (fun () -> ());
let query_time = Unix.gettimeofday () -. conf.query_start in
Util.time_debug conf query_time !GWPARAM.nb_errors !GWPARAM.errors_undef
!GWPARAM.errors_other !GWPARAM.set_vars;
Output.print_sstring conf "</body>\n</html>\n"
let () =
GWPARAM.wrap_output :=
fun conf title content ->
header conf (fun _ -> Output.print_string conf title);
content ();
trailer conf
let incorrect_request ?(comment = "") conf =
!GWPARAM.output_error conf Def.Bad_Request ~content:(Adef.safe comment)
let error_cannot_access conf fname =
!GWPARAM.output_error conf Def.Not_Found
~content:
("Cannot access file \""
^<^ (Util.escape_html fname : Adef.escaped_string :> Adef.safe_string)
^>^ ".txt\".")
let gen_interp header conf fname ifun env ep =
Templ_parser.wrap fname (fun () ->
match Templ.input_templ conf fname with
| Some astl ->
if header then Util.html conf;
let full_name = Util.etc_file_name conf fname in
Templ.interp_ast conf ifun env ep [ Ainclude (full_name, astl) ]
| None -> error_cannot_access conf fname)
let interp_no_header conf fname ifun env ep =
gen_interp false conf fname ifun env ep
let interp conf fname ifun env ep = gen_interp true conf fname ifun env ep
type 'a env = Vint of int | Vother of 'a | Vnone
let get_env v env = try List.assoc v env with Not_found -> Vnone
let get_vother = function Vother x -> Some x | _ -> None
let set_vother x = Vother x
let interp_no_env conf fname =
interp_no_header conf fname
{
Templ.eval_var = (fun _ -> raise Not_found);
Templ.eval_transl = (fun _ -> Templ.eval_transl conf);
Templ.eval_predefined_apply = (fun _ -> raise Not_found);
Templ.get_vother;
Templ.set_vother;
Templ.print_foreach = (fun _ -> raise Not_found);
}
[] ()
(* Calendar request *)
let eval_julian_day conf =
let open Adef in
let getint v = match Util.p_getint conf.env v with Some x -> x | _ -> 0 in
List.fold_left
(fun d (var, cal, conv, max_month) ->
let yy =
match Util.p_getenv conf.env ("y" ^ var) with
| Some v -> (
try
let len = String.length v in
if cal = Djulian && len > 2 && v.[len - 2] = '/' then
int_of_string (String.sub v 0 (len - 2)) + 1
else int_of_string v
with Failure _ -> 0)
| None -> 0
in
let mm = getint ("m" ^ var) in
let dd = getint ("d" ^ var) in
let dt = { day = dd; month = mm; year = yy; prec = Sure; delta = 0 } in
match Util.p_getenv conf.env ("t" ^ var) with
| Some _ -> conv dt
| None -> (
match
( Util.p_getenv conf.env ("y" ^ var ^ "1"),
Util.p_getenv conf.env ("y" ^ var ^ "2"),
Util.p_getenv conf.env ("m" ^ var ^ "1"),
Util.p_getenv conf.env ("m" ^ var ^ "2"),
Util.p_getenv conf.env ("d" ^ var ^ "1"),
Util.p_getenv conf.env ("d" ^ var ^ "2") )
with
| Some _, _, _, _, _, _ -> conv { dt with year = yy - 1 }
| _, Some _, _, _, _, _ -> conv { dt with year = yy + 1 }
| _, _, Some _, _, _, _ ->
let yy, mm =
if mm = 1 then (yy - 1, max_month) else (yy, mm - 1)
in
conv { dt with year = yy; month = mm }
| _, _, _, Some _, _, _ ->
let yy, mm =
if mm = max_month then (yy + 1, 1) else (yy, mm + 1)
in
let r = conv { dt with year = yy; month = mm } in
if r = conv dt then
let yy, mm =
if mm = max_month then (yy + 1, 1) else (yy, mm + 1)
in
conv { dt with year = yy; month = mm }
else r
| _, _, _, _, Some _, _ -> conv { dt with day = dd - 1 }
| _, _, _, _, _, Some _ -> conv { dt with day = dd + 1 }
| _ -> d))
(Calendar.sdn_of_gregorian conf.today)
[
("g", Dgregorian, Calendar.sdn_of_gregorian, 12);
("j", Djulian, Calendar.sdn_of_julian, 12);
("f", Dfrench, Calendar.sdn_of_french, 13);
("h", Dhebrew, Calendar.sdn_of_hebrew, 13);
]
(* *)
let eval_var conf env jd _loc =
let open TemplAst in
function
| [ "integer" ] -> (
match get_env "integer" env with
| Vint i -> VVstring (string_of_int i)
| _ -> raise Not_found)
| "date" :: sl -> TemplDate.eval_date_var conf jd sl
| "today" :: sl ->
TemplDate.eval_date_var conf (Calendar.sdn_of_gregorian conf.today) sl
| _ -> raise Not_found
let print_foreach print_ast eval_expr =
let eval_int_expr env jd e =
let s = eval_expr env jd e in
try int_of_string s with Failure _ -> raise Not_found
in
let rec print_foreach env jd _loc s sl el al =
match (s, sl) with
| "integer_range", [] -> print_integer_range env jd el al
| _ -> raise Not_found
and print_integer_range env jd el al =
let i1, i2 =
match el with
| [ [ e1 ]; [ e2 ] ] -> (eval_int_expr env jd e1, eval_int_expr env jd e2)
| _ -> raise Not_found
in
for i = i1 to i2 do
let env = ("integer", Vint i) :: env in
List.iter (print_ast env jd) al
done
in
print_foreach
let print_calendar conf =
interp conf "calendar"
{
Templ.eval_var = eval_var conf;
Templ.eval_transl = (fun _ -> Templ.eval_transl conf);
Templ.eval_predefined_apply = (fun _ -> raise Not_found);
Templ.get_vother;
Templ.set_vother;
Templ.print_foreach;
}
[] (eval_julian_day conf)

73
lib/hutil.mli Normal file
View File

@@ -0,0 +1,73 @@
(* Copyright (c) 2007 INRIA *)
open Config
val header_without_http : config -> (bool -> unit) -> unit
(** [header_without_http conf title] prints HTML page header in the body of the current response on the socket.
HTML page header consists of :
- <!DOCTYPE> Declaration
- <head> tag where :
- content of <title> tag is printed with [title true]
- <meta> and <link> tags are filled due to [conf]
- content of {i css.txt} template is evaluated and printed
- content of {i hed.txt} template is evaluated and printed
- Opening <body> tag with its attributes
- If user is a wizard or a friend, then includes all messages send to him. *)
val header_without_page_title : config -> (bool -> unit) -> unit
(** Calls for [Util.html] to print HTTP header and for [header_without_http] to print HTML page header.
Additionaly prints opening container <div> tag on the socket. *)
val header : config -> (bool -> unit) -> unit
(** [header conf title] calls for [header_without_page_title] to print HTTP header and HTML page header.
Additionaly prints page title with [title true] (false to print browser tab title). *)
val header_no_page_title : config -> (bool -> unit) -> unit
(** Same as [header] but takes page title from [conf.env]. *)
val header_fluid : config -> (bool -> unit) -> unit
(** Prints HTML page header (without HTTP headers) and opens fluid container <div> (see Bootstrap). *)
val header_link_welcome : config -> (bool -> unit) -> unit
(** Same as [header] but insert links to previous and home pages (with [print_link_to_welcome])
before page title. *)
val trailer : config -> unit
(** [trailer conf] prints HTML page trailer in the body of the current response on the socket.
HTML page trailer consists of :
- Copyright message from template {i copyr.txt} with inserted logo
- Scripts JS from template {i js.txt}
- Closing <body> and <html> tags *)
val rheader : config -> (bool -> unit) -> unit
(** Same as [header] except page's title informs about an occured error (red title). *)
val link_to_referer : config -> Adef.safe_string
(** Returns the HTML link to the previous (referer) page *)
val gen_print_link_to_welcome : (unit -> unit) -> config -> bool -> unit
(** [gen_print_link_to_welcome f conf right_alined] prints links to previous and to home pages.
[f] is used to print additional content before links. *)
val print_link_to_welcome : config -> bool -> unit
(** Calls [gen_print_link_to_welcome] with empty function [f]. *)
val incorrect_request : ?comment:string -> config -> unit
(** Sends [Bad Request] HTTP response (same as [GWPARAM.output_error conf Bad_Request]) *)
(* TODOOCP *)
val interp :
config -> string -> ('a, 'b) Templ.interp_fun -> 'a Templ.env -> 'b -> unit
val interp_no_header :
config -> string -> ('a, 'b) Templ.interp_fun -> 'a Templ.env -> 'b -> unit
val interp_no_env : config -> string -> unit
val print_calendar : config -> unit
(** Displays the calendar; if no key is set, it will use today's date.
Based on template file calendar.txt *)

393
lib/image.ml Normal file
View File

@@ -0,0 +1,393 @@
open Config
open Gwdb
let portrait_folder conf = Util.base_path [ "images" ] conf.bname
let carrousel_folder conf =
Filename.concat (Util.base_path [ "src" ] conf.bname) "images"
(** [default_portrait_filename_of_key fn sn occ] is the default filename
of the corresponding person's portrait. WITHOUT its file extenssion.
e.g: default_portrait_filename_of_key "Jean Claude" "DUPOND" 3 is "jean_claude.3.dupond"
*)
let default_portrait_filename_of_key first_name surname occ =
let space_to_unders = Mutil.tr ' ' '_' in
let f = space_to_unders (Name.lower first_name) in
let s = space_to_unders (Name.lower surname) in
Format.sprintf "%s.%d.%s" f occ s
let default_portrait_filename base p =
default_portrait_filename_of_key (p_first_name base p) (p_surname base p)
(get_occ p)
let authorized_image_file_extension = [| ".jpg"; ".jpeg"; ".png"; ".gif" |]
let find_img_opt f =
let exists ext =
let fname = f ^ ext in
if Sys.file_exists fname then Some fname else None
in
match exists ".url" with
| Some f ->
let ic = open_in f in
let url = input_line ic in
close_in ic;
Some (`Url url)
| None -> (
match Mutil.array_find_map exists authorized_image_file_extension with
| None -> None
| Some f -> Some (`Path f))
(** [full_portrait_path conf base p] is [Some path] if [p] has a portrait.
[path] is a the full path of the file with file extension. *)
let full_portrait_path conf base p =
(* TODO why is extension not in filename..? *)
let s = default_portrait_filename base p in
let f = Filename.concat (portrait_folder conf) s in
match find_img_opt f with
| Some (`Path _) as full_path -> full_path
| Some (`Url _)
(* should not happen, there is only ".url" file in carrousel folder *)
| None ->
None
let source_filename conf src =
let fname1 = Filename.concat (carrousel_folder conf) src in
if Sys.file_exists fname1 then fname1
else
List.fold_right Filename.concat [ Secure.base_dir (); "src"; "images" ] src
let path_of_filename src =
let fname1 =
List.fold_right Filename.concat [ Secure.base_dir (); "images" ] src
in
if Sys.file_exists fname1 then `Path fname1
else `Path (Util.search_in_assets (Filename.concat "images" src))
let png_size ic =
let magic = really_input_string ic 4 in
if magic = "\137PNG" then (
seek_in ic 16;
let wid = input_binary_int ic in
let hei = input_binary_int ic in
Ok (wid, hei))
else Error ()
let gif_size ic =
let magic = really_input_string ic 4 in
if magic = "GIF8" then (
seek_in ic 6;
let wid =
let x = input_byte ic in
(input_byte ic * 256) + x
in
let hei =
let x = input_byte ic in
(input_byte ic * 256) + x
in
Ok (wid, hei))
else Error ()
let jpeg_size ic =
let magic = really_input_string ic 10 in
if
Char.code magic.[0] = 0xff
&& Char.code magic.[1] = 0xd8
&&
let m = String.sub magic 6 4 in
m = "JFIF" || m = "Exif"
then
let exif_type = String.sub magic 6 4 = "Exif" in
let rec loop found =
while Char.code (input_char ic) <> 0xFF do
()
done;
let ch =
let rec loop ch =
if Char.code ch = 0xFF then loop (input_char ic) else ch
in
loop (input_char ic)
in
if Char.code ch = 0xC0 || Char.code ch = 0xC3 then
if exif_type && not found then loop true
else (
for _i = 1 to 3 do
ignore @@ input_char ic
done;
let a = input_char ic in
let b = input_char ic in
let c = input_char ic in
let d = input_char ic in
let wid = (Char.code c lsl 8) lor Char.code d in
let hei = (Char.code a lsl 8) lor Char.code b in
Ok (wid, hei))
else
let a = input_char ic in
let b = input_char ic in
let len = (Char.code a lsl 8) lor Char.code b in
let len = if len >= 32768 then 0 else len in
for _i = 1 to len - 2 do
ignore @@ input_char ic
done;
if Char.code ch <> 0xDA then loop found else Error ()
in
loop false
else Error ()
let size_from_path fname =
(* TODO: size and mime type should be in db *)
let (`Path fname) = fname in
let res =
if fname = "" then Error ()
else
try
let ic = Secure.open_in_bin fname in
let r =
try
(* TODO: should match on mime type here *)
match String.lowercase_ascii @@ Filename.extension fname with
| ".jpeg" | ".jpg" -> jpeg_size ic
| ".png" -> png_size ic
| ".gif" -> gif_size ic
| _s -> Error ()
with End_of_file -> Error ()
in
close_in ic;
r
with Sys_error _e -> Error ()
in
res
let src_to_string = function `Url s | `Path s -> s
let scale_to_fit ~max_w ~max_h ~w ~h =
let w, h =
if h > max_h then
let w = w * max_h / h in
let h = max_h in
(w, h)
else (w, h)
in
let w, h =
if w > max_w then
let h = h * max_w / w in
let w = max_w in
(w, h)
else (w, h)
in
(w, h)
let is_not_private_img _conf fname =
not (Mutil.contains fname ("private" ^ Filename.dir_sep))
(** [has_access_to_portrait conf base p] is true iif we can see [p]'s portrait. *)
let has_access_to_portrait conf base p =
let img = get_image p in
(conf.wizard || conf.friend)
|| (not conf.no_image)
&& Util.authorized_age conf base p
&& ((not (is_empty_string img)) || full_portrait_path conf base p <> None)
&& is_not_private_img conf (sou base img)
(* TODO: privacy settings should be in db not in url *)
(** [has_access_to_carrousel conf base p] is true iif ???. *)
let has_access_to_carrousel conf base p =
(conf.wizard || conf.friend)
|| (not conf.no_image)
&& Util.authorized_age conf base p
&& not (Util.is_hide_names conf p)
let get_portrait_path conf base p =
if has_access_to_portrait conf base p then full_portrait_path conf base p
else None
(* parse a string to an `Url or a `Path *)
let urlorpath_of_string conf s =
let http = "http://" in
let https = "https://" in
if Mutil.start_with http 0 s || Mutil.start_with https 0 s then `Url s
else if Filename.is_implicit s then
match List.assoc_opt "images_path" conf.base_env with
| Some p when p <> "" -> `Path (Filename.concat p s)
| Some _ | None ->
let fname = Filename.concat (portrait_folder conf) s in
`Path fname
else `Path s
let src_of_string conf s =
if s = "" then `Empty
else
let l = String.length s - 1 in
if s.[l] = ')' then `Src_with_size_info s else urlorpath_of_string conf s
let parse_src_with_size_info conf s =
let (`Src_with_size_info s) = s in
let l = String.length s - 1 in
try
let pos1 = String.index s '(' in
let pos2 = String.index_from s pos1 'x' in
let w = String.sub s (pos1 + 1) (pos2 - pos1 - 1) |> int_of_string in
let h = String.sub s (pos2 + 1) (l - pos2 - 1) |> int_of_string in
let s = String.sub s 0 pos1 in
Ok (urlorpath_of_string conf s, (w, h))
with Not_found | Failure _ ->
!GWPARAM.syslog `LOG_ERR
(Format.sprintf "Error parsing portrait source with size info %s" s);
Error "Failed to parse url with size info"
let get_portrait conf base p =
if has_access_to_portrait conf base p then
match src_of_string conf (sou base (get_image p)) with
| `Src_with_size_info _s as s_info -> (
match parse_src_with_size_info conf s_info with
| Error _e -> None
| Ok (s, _size) -> Some s)
| `Url _s as url -> Some url
| `Path p as path -> if Sys.file_exists p then Some path else None
| `Empty -> full_portrait_path conf base p
else None
(* In images/carrousel we store either
- the image as the original image.jpg/png/tif image
- the url to the image as content of a image.url text file
*)
let get_old_portrait conf base p =
if has_access_to_portrait conf base p then
let key = default_portrait_filename base p in
let f =
Filename.concat (Filename.concat (portrait_folder conf) "old") key
in
find_img_opt f
else None
let rename_portrait conf base p (nfn, nsn, noc) =
match get_portrait conf base p with
| Some (`Path old_f) -> (
let new_s = default_portrait_filename_of_key nfn nsn noc in
let old_s = default_portrait_filename base p in
let f = Filename.concat (portrait_folder conf) new_s in
let old_ext = Filename.extension old_f in
let new_f = f ^ old_ext in
(try Sys.rename old_f new_f
with Sys_error e ->
!GWPARAM.syslog `LOG_ERR
(Format.sprintf
"Error renaming portrait: old_path=%s new_path=%s : %s" old_f
new_f e));
let new_s_f =
String.concat Filename.dir_sep [ portrait_folder conf; "old"; new_s ]
in
let old_s_f =
String.concat Filename.dir_sep [ portrait_folder conf; "old"; old_s ]
in
(if Sys.file_exists (old_s_f ^ old_ext) then
try Sys.rename (old_s_f ^ old_ext) (new_s_f ^ old_ext)
with Sys_error e ->
!GWPARAM.syslog `LOG_ERR
(Format.sprintf
"Error renaming old portrait: old_path=%s new_path=%s : %s" old_f
new_f e));
let new_s_f =
String.concat Filename.dir_sep [ carrousel_folder conf; new_s ]
in
let old_s_f =
String.concat Filename.dir_sep [ carrousel_folder conf; old_s ]
in
if Sys.file_exists old_s_f then
try Sys.rename old_s_f new_s_f
with Sys_error e ->
!GWPARAM.syslog `LOG_ERR
(Format.sprintf
"Error renaming carrousel store: old_path=%s new_path=%s : %s"
old_f new_f e))
| Some (`Url _url) -> () (* old url still applies *)
| None -> ()
let get_portrait_with_size conf base p =
if has_access_to_portrait conf base p then
match src_of_string conf (sou base (get_image p)) with
| `Src_with_size_info _s as s_info -> (
match parse_src_with_size_info conf s_info with
| Error _e -> None
| Ok (s, size) -> Some (s, Some size))
| `Url _s as url -> Some (url, None)
| `Path p as path ->
if Sys.file_exists p then
Some (path, size_from_path path |> Result.to_option)
else None
| `Empty -> (
match full_portrait_path conf base p with
| None -> None
| Some path -> Some (path, size_from_path path |> Result.to_option))
else None
(* For carrousel ************************************ *)
let carrousel_file_path conf base p fname old =
let dir =
let dir = default_portrait_filename base p in
if old then Filename.concat dir "old" else dir
in
String.concat Filename.dir_sep
([ carrousel_folder conf; dir ] @ if fname = "" then [] else [ fname ])
let get_carrousel_file_content conf base p fname kind old =
let fname =
Filename.chop_extension (carrousel_file_path conf base p fname old) ^ kind
in
if Sys.file_exists fname then (
let ic = Secure.open_in fname in
let s = really_input_string ic (in_channel_length ic) in
close_in ic;
if s = "" then None else Some s)
else None
(* get list of files in carrousel *)
let get_carrousel_img_aux conf base p old =
let get_carrousel_img_note fname =
Option.value ~default:""
(get_carrousel_file_content conf base p fname ".txt" false)
in
let get_carrousel_img_src fname =
Option.value ~default:""
(get_carrousel_file_content conf base p fname ".src" false)
in
let get_carrousel_img fname =
let path = carrousel_file_path conf base p fname old in
find_img_opt (Filename.chop_extension path)
in
if not (has_access_to_carrousel conf base p) then []
else
let f = carrousel_file_path conf base p "" old in
try
if Sys.file_exists f && Sys.is_directory f then
Array.fold_left
(fun acc f1 ->
let ext = Filename.extension f1 in
if
f1 <> ""
&& f1.[0] <> '.'
&& (Array.mem ext authorized_image_file_extension || ext = ".url")
then
match get_carrousel_img f1 with
| None -> acc
| Some (`Path path) ->
(path, "", get_carrousel_img_src f1, get_carrousel_img_note f1)
:: acc
| Some (`Url url) ->
( Filename.chop_extension (Filename.basename f1) ^ ".url",
url,
get_carrousel_img_src f1,
get_carrousel_img_note f1 )
:: acc
else acc)
[] (Sys.readdir f)
else []
with Sys_error e ->
!GWPARAM.syslog `LOG_ERR (Format.sprintf "carrousel error: %s, %s" f e);
[]
let get_carrousel_imgs conf base p = get_carrousel_img_aux conf base p false
let get_carrousel_old_imgs conf base p = get_carrousel_img_aux conf base p true
(* end carrousel ************************************ *)

75
lib/image.mli Normal file
View File

@@ -0,0 +1,75 @@
open Config
open Gwdb
val portrait_folder : config -> string
val carrousel_folder : config -> string
val authorized_image_file_extension : string array
val scale_to_fit : max_w:int -> max_h:int -> w:int -> h:int -> int * int
(** [scale_to_fit ~max_w ~max_h ~w ~h] is the {(width, height)} of a proportionally scaled {(w, h)} rectangle so it can fit in a {(max_w, max_h)} rectangle *)
val source_filename : config -> string -> string
(** Returns path to the image file with the giving name in directory {i src/}. *)
(* TODO this should be removed *)
val default_portrait_filename : base -> person -> string
(** [default_portrait_filename base p] is the default filename of [p]'s portrait. Without it's file extension.
e.g: default_portrait_filename_of_key "Jean Claude" "DUPOND" 3 is "jean_claude.3.dupond"
*)
val size_from_path : [ `Path of string ] -> (int * int, unit) result
(** [size_from_path path]
- Error () if failed to read or parse file
- Ok (width, height) of the file.
It works by opening the file and reading magic numbers *)
val path_of_filename : string -> [> `Path of string ]
(** [path_of_filename fname] search for image {i images/fname} inside the base and assets directories.
Return the path to found file or [fname] if file isn't found. *)
val rename_portrait : config -> base -> person -> string * string * int -> unit
(** Rename portrait to match updated name *)
val src_to_string : [< `Path of string | `Url of string ] -> string
(** [src_to_string src] is [src] as a string *)
(* TODO this should be removed *)
val get_portrait_path : config -> base -> person -> [> `Path of string ] option
(** [get_portrait_path conf base p] is
- [None] if we don't have access to [p]'s portrait or it doesn't exist.
- [Some path] with [path] the full path with extension of [p]'s portrait.
*)
val get_portrait_with_size :
config ->
base ->
person ->
([> `Path of string | `Url of string ] * (int * int) option) option
(** [get_portrait_with_size conf base p] is
- [None] if we don't have access to [p]'s portrait or it doesn't exist.
- [Some (src, size_opt)] with [src] the url or path of [p]'s portrait. [size_opt] is the (width,height) of the portrait if we could recover them *)
val get_portrait :
config -> base -> person -> [> `Path of string | `Url of string ] option
(** [get_portrait conf base p] is
- [None] if we don't have access to [p]'s portrait or it doesn't exist.
- [Some src] with [src] the url or path of [p]'s portrait.
*)
val get_old_portrait :
config -> base -> person -> [> `Path of string | `Url of string ] option
(** [get_portrait conf base p] is
- [None] if we don't have access to [p]'s portrait or it doesn't exist.
- [Some src] with [src] the url or path of [p]'s portrait.
*)
(* -- Carrousel -- *)
val get_carrousel_imgs :
config -> base -> person -> (string * string * string * string) list
val get_carrousel_old_imgs :
config -> base -> person -> (string * string * string * string) list
val is_not_private_img : config -> string -> bool
(** determines if image is private (pathname contains "private/") *)

756
lib/imageCarrousel.ml Normal file
View File

@@ -0,0 +1,756 @@
open Config
open Def
open Gwdb
open Util
let rn fname s =
try if Sys.file_exists fname then Sys.rename fname s
with Failure _ ->
Printf.eprintf "Rn failed: %s to %s\n" fname s;
flush stderr
type image_type = JPEG | GIF | PNG
let extension_of_type = function
| JPEG -> ".jpg"
| GIF -> ".gif"
| PNG -> ".png"
let image_types = [ JPEG; GIF; PNG ]
let raise_modErr s = raise @@ Update.ModErr (Update.UERR s)
let incorrect conf str =
Hutil.incorrect_request conf ~comment:str;
failwith (__FILE__ ^ " (" ^ str ^ ")" :> string)
let incorrect_content_type conf base p s =
let title _ =
Output.print_sstring conf (Utf8.capitalize (Util.transl conf "error"))
in
Hutil.rheader conf title;
Hutil.print_link_to_welcome conf true;
Output.print_sstring conf "<p>\n<em style=\"font-size:smaller\">";
Output.printf conf "Error: incorrect image content type: %s" s;
Output.printf conf "</em>\n</p>\n<ul>\n<li>\n%s</li>\n</ul>\n"
(Util.referenced_person_title_text conf base p :> string);
Hutil.trailer conf;
failwith (__FILE__ ^ " " ^ string_of_int __LINE__ :> string)
let error_too_big_image conf base p len max_len =
let title _ =
Output.print_sstring conf (Utf8.capitalize (Util.transl conf "error"))
in
Hutil.rheader conf title;
Hutil.print_link_to_welcome conf true;
Output.print_sstring conf "<p><em style=\"font-size:smaller\">";
Output.printf conf "Error: this image is too big: %d bytes<br>\n" len;
Output.printf conf "Maximum authorized in this database: %d bytes<br>\n"
max_len;
Output.printf conf "</em></p>\n<ul>\n<li>\n%s</li>\n</ul>\n"
(Util.referenced_person_title_text conf base p :> string);
Hutil.trailer conf;
failwith (__FILE__ ^ " " ^ string_of_int __LINE__ :> string)
let raw_get conf key =
try List.assoc key conf.env
with Not_found -> incorrect conf ("raw_get" ^ key)
let insert_saved fname =
let l = String.split_on_char Filename.dir_sep.[0] fname |> List.rev in
let l = List.rev @@ match l with h :: t -> h :: "old" :: t | _ -> l in
String.concat Filename.dir_sep l
let write_file fname content =
let oc = Secure.open_out_bin fname in
output_string oc content;
flush oc;
close_out oc
let move_file_to_save file dir =
(* previous version iterated on file types *)
try
let save_dir = Filename.concat dir "old" in
if not (Sys.file_exists save_dir) then Mutil.mkdir_p save_dir;
let fname = Filename.basename file in
let orig_file = Filename.concat dir fname in
let saved_file = Filename.concat save_dir fname in
(* TODO handle rn errors *)
rn orig_file saved_file;
let orig_file_t = Filename.remove_extension orig_file ^ ".txt" in
let saved_file_t = Filename.remove_extension saved_file ^ ".txt" in
if Sys.file_exists orig_file_t then rn orig_file_t saved_file_t;
let orig_file_s = Filename.remove_extension orig_file ^ ".src" in
let saved_file_s = Filename.remove_extension saved_file ^ ".src" in
if Sys.file_exists orig_file_s then rn orig_file_s saved_file_s;
1
with _ -> 0
let normal_image_type s =
if String.length s > 10 && Char.code s.[0] = 0xff && Char.code s.[1] = 0xd8
then Some JPEG
else if String.length s > 4 && String.sub s 0 4 = "\137PNG" then Some PNG
else if String.length s > 4 && String.sub s 0 4 = "GIF8" then Some GIF
else None
let string_search s v =
let rec loop i j =
if j = String.length v then Some (i - String.length v)
else if i = String.length s then None
else if s.[i] = v.[j] then loop (i + 1) (j + 1)
else loop (i + 1) 0
in
loop 0 0
(* get the image type, possibly removing spurious header *)
let image_type s =
match normal_image_type s with
| Some t -> Some (t, s)
| None -> (
match string_search s "JFIF" with
| Some i when i > 6 ->
let s = String.sub s (i - 6) (String.length s - i + 6) in
Some (JPEG, s)
| _ -> (
match string_search s "\137PNG" with
| Some i ->
let s = String.sub s i (String.length s - i) in
Some (PNG, s)
| _ -> (
match string_search s "GIF8" with
| Some i ->
let s = String.sub s i (String.length s - i) in
Some (GIF, s)
| None -> None)))
let dump_bad_image conf s =
match List.assoc_opt "dump_bad_images" conf.base_env with
| Some "yes" -> (
try
(* Where will "bad-image"end up? *)
let oc = Secure.open_out_bin "bad-image" in
output_string oc s;
flush oc;
close_out oc
with Sys_error _ -> ())
| _ -> ()
(* swap files between new and old folder *)
(* [| ".jpg"; ".jpeg"; ".png"; ".gif" |] *)
let swap_files_aux dir file ext old_ext =
let old_file =
String.concat Filename.dir_sep [ dir; "old"; Filename.basename file ]
in
let tmp_file = String.concat Filename.dir_sep [ dir; "tempfile.tmp" ] in
if ext <> old_ext then (
if Sys.file_exists file then rn file (Filename.chop_extension old_file ^ ext);
if Sys.file_exists old_file then
rn old_file (Filename.chop_extension file ^ old_ext))
else (
if Sys.file_exists file then rn file tmp_file;
if Sys.file_exists old_file then rn old_file file;
if Sys.file_exists tmp_file then rn tmp_file old_file)
let swap_files file ext old_ext =
let dir = Filename.dirname file in
let fname = Filename.basename file in
swap_files_aux dir file ext old_ext;
let txt_file =
String.concat Filename.dir_sep
[ dir; Filename.chop_extension fname ^ ".txt" ]
in
swap_files_aux dir txt_file ext old_ext;
let src_file =
String.concat Filename.dir_sep
[ dir; Filename.chop_extension fname ^ ".src" ]
in
swap_files_aux dir src_file ext old_ext
let clean_saved_portrait file =
let file = Filename.remove_extension file in
Array.iter
(fun ext -> Mutil.rm (file ^ ext))
Image.authorized_image_file_extension
let get_extension conf saved fname =
let f =
if saved then
String.concat Filename.dir_sep
[ Util.base_path [ "images" ] conf.bname; "old"; fname ]
else
String.concat Filename.dir_sep
[ Util.base_path [ "images" ] conf.bname; fname ]
in
if Sys.file_exists (f ^ ".jpg") then ".jpg"
else if Sys.file_exists (f ^ ".jpeg") then ".jpeg"
else if Sys.file_exists (f ^ ".png") then ".png"
else if Sys.file_exists (f ^ ".gif") then ".gif"
else if Sys.file_exists (f ^ ".url") then ".url"
else "."
let print_confirm_c conf base save_m report =
match Util.p_getint conf.env "i" with
| Some ip ->
let p = poi base (Gwdb.iper_of_string (string_of_int ip)) in
let digest = Image.default_portrait_filename base p in
let new_env =
List.fold_left
(fun accu (k, v) ->
if k = "m" then ("m", Adef.encoded "REFRESH") :: accu
else if k = "idigest" || k = "" || k = "file" then accu
else (k, v) :: accu)
[] conf.env
in
let new_env =
if save_m = "REFRESH" then new_env
else ("em", Adef.encoded save_m) :: new_env
in
let new_env =
("idigest", Adef.encoded digest)
:: ("report", Adef.encoded report)
:: new_env
in
let conf = { conf with env = new_env } in
Perso.interp_templ "carrousel" conf base p
| None -> Hutil.incorrect_request conf
(* ************************************************************************ *)
(* send, delete, reset and print functions *)
(* *)
(* ************************************************************************ *)
(* we need print_link_delete_image in the send function *)
let print_link_delete_image conf base p =
if Option.is_some @@ Image.get_portrait conf base p then (
Output.print_sstring conf {|<p><a class="btn btn-primary" href="|};
Output.print_string conf (commd conf);
Output.print_sstring conf "m=DEL_IMAGE&i=";
Output.print_string conf (get_iper p |> string_of_iper |> Mutil.encode);
Output.print_sstring conf {|">|};
transl conf "delete" |> Utf8.capitalize_fst |> Output.print_sstring conf;
Output.print_sstring conf {| |};
transl_nth conf "image/images" 0 |> Output.print_sstring conf;
Output.print_sstring conf "</a></p>")
let print_send_image conf base p =
let title h =
if Option.is_some @@ Image.get_portrait conf base p then
transl_nth conf "image/images" 0
|> transl_decline conf "modify"
|> Utf8.capitalize_fst |> Output.print_sstring conf
else
transl_nth conf "image/images" 0
|> transl_decline conf "add" |> Utf8.capitalize_fst
|> Output.print_sstring conf;
if not h then (
Output.print_sstring conf (transl conf ":");
Output.print_sstring conf " ";
Output.print_string conf (Util.escape_html (p_first_name base p));
Output.print_sstring conf (Format.sprintf ".%d " (get_occ p));
Output.print_string conf (Util.escape_html (p_surname base p)))
in
let digest = Update.digest_person (UpdateInd.string_person_of base p) in
Perso.interp_notempl_with_menu title "perso_header" conf base p;
Output.print_sstring conf "<h2>\n";
title false;
Output.print_sstring conf "</h2>\n";
Output.printf conf
"<form method=\"post\" action=\"%s\" enctype=\"multipart/form-data\">\n"
conf.command;
Output.print_sstring conf "<p>\n";
Util.hidden_env conf;
Util.hidden_input conf "m" (Adef.encoded "SND_IMAGE_OK");
Util.hidden_input conf "i" (get_iper p |> string_of_iper |> Mutil.encode);
Util.hidden_input conf "digest" (Mutil.encode digest);
Output.print_sstring conf (Utf8.capitalize_fst (transl conf "file"));
Output.print_sstring conf (Util.transl conf ":");
Output.print_sstring conf " ";
Output.print_sstring conf
{| <input type="file" class="form-control-file" name="file" accept="image/*"></p>|};
(match
Option.map int_of_string @@ List.assoc_opt "max_images_size" conf.base_env
with
| Some len ->
Output.print_sstring conf "<p>(maximum authorized size = ";
Output.print_sstring conf (string_of_int len);
Output.print_sstring conf " bytes)</p>"
| None -> ());
Output.print_sstring conf
{|<button type="submit" class="btn btn-primary mt-2">|};
transl_nth conf "validate/delete" 0
|> Utf8.capitalize_fst |> Output.print_sstring conf;
Output.print_sstring conf "</button></form>";
print_link_delete_image conf base p;
Hutil.trailer conf
let print_sent conf base p =
let title _ =
transl conf "image received"
|> Utf8.capitalize_fst |> Output.print_sstring conf
in
Hutil.header conf title;
Output.print_sstring conf "<ul><li>";
Output.print_string conf (referenced_person_text conf base p);
Output.print_sstring conf "</li></ul>";
Hutil.trailer conf
let effective_send_ok conf base p file =
let mode =
try (List.assoc "mode" conf.env :> string) with Not_found -> "portraits"
in
let strm = Stream.of_string file in
let request, content = Wserver.get_request_and_content strm in
let content =
let s =
let rec loop len (strm__ : _ Stream.t) =
match Stream.peek strm__ with
| Some x ->
Stream.junk strm__;
loop (Buff.store len x) strm
| _ -> Buff.get len
in
loop 0 strm
in
(content :> string) ^ s
in
let typ, content =
match image_type content with
| None ->
dump_bad_image conf content;
Mutil.extract_param "content-type: " '\n' request
|> incorrect_content_type conf base p
| Some (typ, content) -> (
match
Option.map int_of_string
@@ List.assoc_opt "max_images_size" conf.base_env
with
| Some len when String.length content > len ->
error_too_big_image conf base p (String.length content) len
| _ -> (typ, content))
in
let fname = Image.default_portrait_filename base p in
let dir = Util.base_path [ "images" ] conf.bname in
if not (Sys.file_exists dir) then Mutil.mkdir_p dir;
let fname =
Filename.concat dir
(if mode = "portraits" then fname ^ extension_of_type typ else fname)
in
let _moved = move_file_to_save fname dir in
write_file fname content;
let changed =
U_Send_image (Util.string_gen_person base (gen_person_of_person p))
in
History.record conf base changed "si";
print_sent conf base p
let print_send_ok conf base =
let ip =
try raw_get conf "i" |> Mutil.decode |> iper_of_string
with Failure _ -> incorrect conf "print send ok"
in
let p = poi base ip in
let digest = Update.digest_person (UpdateInd.string_person_of base p) in
if (digest :> string) = Mutil.decode (raw_get conf "digest") then
raw_get conf "file" |> Adef.as_string |> effective_send_ok conf base p
else Update.error_digest conf
(* carrousel *)
let effective_send_c_ok conf base p file file_name =
let mode =
try (List.assoc "mode" conf.env :> string) with Not_found -> "portraits"
in
let image_url =
try (List.assoc "image_url" conf.env :> string) with Not_found -> ""
in
let image_name =
try (List.assoc "image_name" conf.env :> string) with Not_found -> ""
in
let note =
match Util.p_getenv conf.env "note" with
| Some v ->
Util.safe_html
(Util.only_printable_or_nl (Mutil.strip_all_trailing_spaces v))
| None -> Adef.safe ""
in
let source =
match Util.p_getenv conf.env "source" with
| Some v ->
Util.safe_html
(Util.only_printable_or_nl (Mutil.strip_all_trailing_spaces v))
| None -> Adef.safe ""
in
let strm = Stream.of_string file in
let request, content = Wserver.get_request_and_content strm in
let content =
if mode = "note" || mode = "source" || image_url <> "" then ""
else
let s =
let rec loop len (strm__ : _ Stream.t) =
match Stream.peek strm__ with
| Some x ->
Stream.junk strm__;
loop (Buff.store len x) strm
| _ -> Buff.get len
in
loop 0 strm
in
(content :> string) ^ s
in
let typ, content =
if content <> "" then
match image_type content with
| None ->
let ct = Mutil.extract_param "Content-Type: " '\n' request in
dump_bad_image conf content;
incorrect_content_type conf base p ct
| Some (typ, content) -> (
match List.assoc_opt "max_images_size" conf.base_env with
| Some len when String.length content > int_of_string len ->
error_too_big_image conf base p (String.length content)
(int_of_string len)
| _ -> (typ, content))
else (GIF, content (* we dont care which type, content = "" *))
in
let fname = Image.default_portrait_filename base p in
let dir =
if mode = "portraits" then
String.concat Filename.dir_sep [ Util.base_path [ "images" ] conf.bname ]
else
String.concat Filename.dir_sep
[ Util.base_path [ "src" ] conf.bname; "images"; fname ]
in
if not (Sys.file_exists dir) then Mutil.mkdir_p dir;
let fname =
Filename.concat dir
(if mode = "portraits" then fname ^ extension_of_type typ else file_name)
in
if mode = "portraits" then
match Image.get_portrait conf base p with
| Some (`Path portrait) ->
if move_file_to_save portrait dir = 0 then
incorrect conf "effective send (portrait)"
| Some (`Url url) -> (
let fname = Image.default_portrait_filename base p in
let dir = Filename.concat dir "old" in
if not (Sys.file_exists dir) then Mutil.mkdir_p dir;
let fname = Filename.concat dir fname ^ ".url" in
try write_file fname url
with _ ->
incorrect conf
(Printf.sprintf "effective send (effective send url portrait %s)"
fname)
(* TODO update person to supress url image *))
| _ -> ()
else if content <> "" then
if Sys.file_exists fname then
if move_file_to_save fname dir = 0 then
incorrect conf "effective send (image)";
let fname =
if image_url <> "" then Filename.concat dir image_name ^ ".url" else fname
in
if content <> "" then
try write_file fname content
with _ ->
incorrect conf
(Printf.sprintf "effective send (writing content file %s)" fname)
else if image_url <> "" then
try write_file fname image_url
with _ ->
incorrect conf
(Printf.sprintf "effective send (writing .url file %s)" fname)
else ();
if note <> Adef.safe "" then
let fname = Filename.remove_extension fname ^ ".txt" in
try write_file fname (note :> string)
with _ ->
incorrect conf
(Printf.sprintf "effective send (writing .txt file %s)" fname)
else ();
if source <> Adef.safe "" then
let fname = Filename.remove_extension fname ^ ".src" in
try write_file fname (source :> string)
with _ ->
incorrect conf
(Printf.sprintf "effective send (writing .txt file %s)" fname)
else ();
let changed =
U_Send_image (Util.string_gen_person base (gen_person_of_person p))
in
History.record conf base changed
(if mode = "portraits" then "si"
else if file_name <> "" && note <> Adef.safe "" && source <> Adef.safe ""
then "sb"
else if file_name <> "" then "so"
else if note <> Adef.safe "" then "sc"
else if source <> Adef.safe "" then "ss"
else "sn");
file_name
(* Delete *)
let print_delete_image conf base p =
let title h =
transl_nth conf "image/images" 0
|> transl_decline conf "delete"
|> Utf8.capitalize_fst |> Output.print_sstring conf;
if not h then (
let fn = p_first_name base p in
let sn = p_surname base p in
let occ = get_occ p in
Output.print_sstring conf (Util.transl conf ":");
Output.print_sstring conf " ";
Output.print_string conf (Util.escape_html fn);
Output.print_sstring conf ".";
Output.print_sstring conf (string_of_int occ);
Output.print_sstring conf " ";
Output.print_string conf (Util.escape_html sn))
in
Hutil.header conf title;
Output.printf conf "<form method=\"post\" action=\"%s\">" conf.command;
Util.hidden_env conf;
Util.hidden_input conf "m" (Adef.encoded "DEL_IMAGE_OK");
Util.hidden_input conf "i" (get_iper p |> string_of_iper |> Mutil.encode);
Output.print_sstring conf
{|<p><button type="submit" class="btn btn-primary">|};
transl_nth conf "validate/delete" 1
|> Utf8.capitalize_fst |> Output.print_sstring conf;
Output.print_sstring conf {|</button></p></form>|};
Hutil.trailer conf
let print_deleted conf base p =
let title _ =
transl conf "image deleted"
|> Utf8.capitalize_fst |> Output.print_sstring conf
in
Hutil.header conf title;
Output.print_sstring conf "<ul><li>";
Output.print_string conf (referenced_person_text conf base p);
Output.print_sstring conf "</li></ul>";
Hutil.trailer conf
let effective_delete_ok conf base p =
let fname = Image.default_portrait_filename base p in
let ext = get_extension conf false fname in
let dir = Util.base_path [ "images" ] conf.bname in
if move_file_to_save (fname ^ ext) dir = 0 then
incorrect conf "effective delete";
let changed =
U_Delete_image (Util.string_gen_person base (gen_person_of_person p))
in
History.record conf base changed "di";
print_deleted conf base p
let print_del_ok conf base =
match p_getenv conf.env "i" with
| Some ip ->
let p = poi base (iper_of_string ip) in
effective_delete_ok conf base p
| None -> incorrect conf "print del ok"
let print_del conf base =
match p_getenv conf.env "i" with
| None -> Hutil.incorrect_request conf
| Some ip -> (
let p = poi base (iper_of_string ip) in
match Image.get_portrait conf base p with
| Some _ -> print_delete_image conf base p
| None -> Hutil.incorrect_request conf)
(*carrousel *)
(* removes portrait or other image and saves it into old folder *)
(* if delete=on permanently deletes the file in old folder *)
let effective_delete_c_ok conf base p =
let fname = Image.default_portrait_filename base p in
let file_name =
try List.assoc "file_name" conf.env with Not_found -> Adef.encoded ""
in
let file_name = (Mutil.decode file_name :> string) in
let mode =
try (List.assoc "mode" conf.env :> string) with Not_found -> "portraits"
in
let delete =
try List.assoc "delete" conf.env = Adef.encoded "on"
with Not_found -> false
in
let ext = get_extension conf delete fname in
let file = if file_name = "" then fname ^ ext else file_name in
let dir =
if mode = "portraits" then Util.base_path [ "images" ] conf.bname
else
String.concat Filename.dir_sep
[ Util.base_path [ "src" ] conf.bname; "images"; fname ]
in
if not (Sys.file_exists dir) then Mutil.mkdir_p dir;
(* TODO verify we dont destroy a saved image
having the same name as portrait! *)
if delete then Mutil.rm (String.concat Filename.dir_sep [ dir; "old"; file ])
else if move_file_to_save file dir = 0 then incorrect conf "effective delete";
let changed =
U_Delete_image (Util.string_gen_person base (gen_person_of_person p))
in
History.record conf base changed (if mode = "portraits" then "di" else "do");
file_name
(* carrousel *)
(* reset portrait or image from old folder to portrait or others *)
let effective_reset_c_ok conf base p =
let mode =
try (List.assoc "mode" conf.env :> string) with Not_found -> "portraits"
in
let carrousel = Image.default_portrait_filename base p in
let file_name =
try List.assoc "file_name" conf.env with Not_found -> Adef.encoded ""
in
let file_name = (Mutil.decode file_name :> string) in
let file_name = if mode = "portraits" then carrousel else file_name in
let ext = get_extension conf false file_name in
let old_ext = get_extension conf true file_name in
let ext =
match Image.get_portrait conf base p with
| Some src ->
if Mutil.start_with "http" 0 (Image.src_to_string src) then ".url"
else ext
| _ -> ext
in
let file_in_new =
if mode = "portraits" then
String.concat Filename.dir_sep
[ Util.base_path [ "images" ] conf.bname; file_name ^ ext ]
else
String.concat Filename.dir_sep
[ Util.base_path [ "src" ] conf.bname; "images"; carrousel; file_name ]
in
(if Sys.file_exists file_in_new then ()
else
match Image.get_portrait conf base p with
| Some (`Url url) -> (
try write_file file_in_new url
with _ ->
incorrect conf
(Printf.sprintf "reset portrait (swap file %s)" file_in_new))
| _ -> ());
swap_files file_in_new ext old_ext;
file_name
(* ************************************************************************** *)
(* [Fonc] print : Config.config -> Gwdb.base -> unit *)
(* ************************************************************************** *)
(* most functions in GeneWeb end with a COMMAND_OK confirmation step *)
(* for carrousel, we have chosen to ignore this step and refresh *)
(* the updated page directly *)
(* if em="" this is the first pass, do it *)
let print_main_c conf base =
match Util.p_getenv conf.env "em" with
| None -> (
match Util.p_getenv conf.env "m" with
| Some m -> (
let save_m = m in
match Util.p_getenv conf.env "i" with
| Some ip -> (
let p = poi base (Gwdb.iper_of_string ip) in
let digest = Image.default_portrait_filename base p in
let conf, report =
match Util.p_getenv conf.env "m" with
| Some "SND_IMAGE_C_OK" ->
let mode =
try (List.assoc "mode" conf.env :> string)
with Not_found -> "portraits"
in
let file_name =
try (List.assoc "file_name" conf.env :> string)
with Not_found -> ""
in
let file_name =
if file_name = "" then
try (List.assoc "file_name_2" conf.env :> string)
with Not_found -> ""
else file_name
in
let file_name =
(Mutil.decode (Adef.encoded file_name) :> string)
in
let file_name_2 = Filename.remove_extension file_name in
let new_env =
List.fold_left
(fun accu (k, v) ->
if k = "file_name_2" then
(k, Adef.encoded file_name_2) :: accu
else (k, v) :: accu)
[] conf.env
in
let conf = { conf with env = new_env } in
let file =
if mode = "note" || mode = "source" then "file_name"
else (raw_get conf "file" :> string)
in
let idigest =
try (List.assoc "idigest" conf.env :> string)
with Not_found -> ""
in
if digest = idigest then
(conf, effective_send_c_ok conf base p file file_name)
else (conf, "idigest error")
| Some "DEL_IMAGE_C_OK" ->
let idigest =
try (List.assoc "idigest" conf.env :> string)
with Not_found -> ""
in
if digest = idigest then
(conf, effective_delete_c_ok conf base p)
else (conf, "idigest error")
| Some "RESET_IMAGE_C_OK" ->
let idigest =
try (List.assoc "idigest" conf.env :> string)
with Not_found -> ""
in
if digest = idigest then
(conf, effective_reset_c_ok conf base p)
else (conf, "idigest error")
| Some "IMAGE_C" -> (conf, "image")
| _ -> (conf, "incorrect request")
in
match report with
| "idigest error" ->
failwith
(__FILE__ ^ " idigest error, line " ^ string_of_int __LINE__
:> string)
| "incorrect request" -> Hutil.incorrect_request conf
| _ -> print_confirm_c conf base save_m report)
| None -> Hutil.incorrect_request conf)
| None -> Hutil.incorrect_request conf)
(* em!="" second pass, ignore *)
| Some _ -> print_confirm_c conf base "REFRESH" ""
let print conf base =
match p_getenv conf.env "i" with
| None -> Hutil.incorrect_request conf
| Some ip ->
let p = poi base (iper_of_string ip) in
let fn = p_first_name base p in
let sn = p_surname base p in
if fn = "?" || sn = "?" then Hutil.incorrect_request conf
else print_send_image conf base p
(* carrousel *)
let print_c ?(saved = false) conf base =
match (Util.p_getenv conf.env "s", Util.find_person_in_env conf base "") with
| Some f, Some p ->
let k = Image.default_portrait_filename base p in
let f = Filename.concat k f in
ImageDisplay.print_source conf (if saved then insert_saved f else f)
| Some f, _ -> ImageDisplay.print_source conf f
| _, Some p -> (
match
(if saved then Image.get_old_portrait else Image.get_portrait)
conf base p
with
| Some (`Path f) ->
Result.fold ~ok:ignore
~error:(fun _ -> Hutil.incorrect_request conf)
(ImageDisplay.print_image_file conf f)
| _ -> Hutil.incorrect_request conf)
| _, _ -> Hutil.incorrect_request conf

159
lib/imageDisplay.ml Normal file
View File

@@ -0,0 +1,159 @@
(* $Id: image.ml,v 5.8 2009-03-11 09:22:39 ddr Exp $ *)
(* Copyright (c) 1998-2007 INRIA *)
open Config
let print_placeholder_gendered_portrait conf p size =
let open Gwdb in
let image, alt =
match get_sex p with
| Male -> ("male.png", "M")
| Female -> ("female.png", "F")
| Neuter -> ("sexunknown.png", "?")
in
Output.printf conf
{|<img src="%s/%s" alt="%s" title="sex" width="%d" height="%d">|}
(Util.images_prefix conf) image alt size size
(* ************************************************************************** *)
(* [Fonc] content : string -> int -> string -> unit *)
(* ************************************************************************** *)
(** [Description] : Envoie les en-têtes de contenu et de cache pour un fichier
image, pdf ou html sur le flux HTTP sortant de Wserver.
[Args] :
- ct : le content_type MIME du fichier, par exemple "image/png",
"image/jpeg" ou "application/pdf"
- len : la taille en octet du fichier
- fname : le nom du fichier
[Retour] : aucun
[Rem] : Ne pas utiliser en dehors de ce module. *)
let content conf ct len fname =
Output.status conf Def.OK;
Output.header conf "Content-type: %s" ct;
Output.header conf "Content-length: %d" len;
Output.header conf "Content-disposition: inline; filename=%s"
(Filename.basename fname);
(* TODO: Utiliser un cache public pour les images non personelles. *)
Output.header conf "Cache-control: private, max-age=%d" (60 * 60 * 24 * 365);
Output.flush conf
let print_image_file conf fname =
let res =
List.find_opt
(fun (suff, _ctype) ->
if
Filename.check_suffix fname suff
|| Filename.check_suffix fname (String.uppercase_ascii suff)
then true
else false)
[
(".png", "image/png");
(".jpg", "image/jpeg");
(".jpeg", "image/jpeg");
(".pjpeg", "image/jpeg");
(".gif", "image/gif");
(".pdf", "application/pdf");
(".htm", "text/html");
(".html", "text/html");
]
in
match res with
| None ->
Error
(Format.sprintf "Could not find mime type from extension for file: %s"
fname)
| Some (_suff, ctype) -> (
try
let ic = Secure.open_in_bin fname in
let buf = Bytes.create 1024 in
let len = in_channel_length ic in
content conf ctype len fname;
let rec loop len =
if len = 0 then ()
else
let olen = min (Bytes.length buf) len in
really_input ic buf 0 olen;
Output.print_sstring conf (Bytes.sub_string buf 0 olen);
loop (len - olen)
in
loop len;
close_in ic;
Ok ()
with Sys_error e ->
!GWPARAM.syslog `LOG_ERR
(Format.sprintf "Error printing image file content for %s : %s" fname
e);
Error e)
(* ************************************************************************** *)
(* [Fonc] print_portrait : Config.config -> Gwdb.base -> Gwdb.person -> unit *)
(* ************************************************************************** *)
(** [Description] : Affiche l'image d'une personne en réponse HTTP.
[Args] :
- conf : configuration de la requête
- base : base de donnée sélectionnée
- p : personne dans la base dont il faut afficher l'image
[Retour] : aucun
[Rem] : Ne pas utiliser en dehors de ce module. *)
let print_portrait conf base p =
match Image.get_portrait conf base p with
| Some (`Path path) ->
Result.fold ~ok:ignore
~error:(fun _ -> Hutil.incorrect_request conf)
(print_image_file conf path)
| Some (`Url url) ->
Util.html conf;
Output.print_sstring conf "<head><title>";
Output.print_sstring conf (Util.transl_nth conf "image/images" 0);
Output.print_sstring conf "</title></head><body>";
Output.print_sstring conf (Printf.sprintf {|<img src=%s>|} url);
Output.print_sstring conf "</body></html>"
| None -> Hutil.incorrect_request conf
let print_source conf f =
let fname = if f.[0] = '/' then String.sub f 1 (String.length f - 1) else f in
let fname = Image.source_filename conf fname in
if (conf.wizard || conf.friend) || Image.is_not_private_img conf fname then
Result.fold ~ok:ignore
~error:(fun _ -> Hutil.incorrect_request conf)
(print_image_file conf fname)
else Hutil.incorrect_request conf
let print conf base =
match Util.p_getenv conf.env "s" with
| Some f -> print_source conf f
| None -> (
match Util.find_person_in_env conf base "" with
| Some p -> print_portrait conf base p
| None -> Hutil.incorrect_request conf)
let print_html conf =
let ext =
match Util.p_getenv conf.env "s" with
| Some f -> Filename.extension f
| _ -> ""
in
match ext with
| ".htm" | ".html" | ".pdf" ->
let title _ = Output.print_sstring conf "Error" in
Hutil.header conf title;
Output.print_sstring conf
"<body><ul><li>DOCH not available for html and pdf.";
Hutil.trailer conf
| _ ->
Util.html conf;
Output.print_sstring conf "<head><title>";
Output.print_sstring conf (Util.transl_nth conf "image/images" 0);
Output.print_sstring conf "</title></head><body><img src=\"";
Output.print_string conf (Util.commd conf);
Mutil.list_iter_first
(fun first (k, v) ->
let v = if k = "m" then Adef.encoded "IM" else v in
if not first then Output.print_sstring conf "&";
Output.print_sstring conf k;
Output.print_sstring conf "=";
Output.print_string conf v)
conf.env;
Output.print_sstring conf "\"></body></html>"

24
lib/imageDisplay.mli Normal file
View File

@@ -0,0 +1,24 @@
open Config
val print_image_file : config -> string -> (unit, string) result
(** [print_image_file conf fname] send HTTP respose with content of an image
file at the path [fname].
MIME type of an image is deducted from [fname] extension. Returns [false]
if image wasn't found or couldn't be send. *)
val print_source : config -> string -> unit
(** Display an image of given filename in images folder
Filename may contain sub-folders, but cannot point outside images *)
val print : config -> Gwdb.base -> unit
(** Searches image's filename in the environement [conf.env] and sends
HTTP response with its content on the socket. If filename isn't presented,
looks up personal image (portrait) for person mentionned in [conf.env] *)
val print_html : config -> unit
(** Sends HTTP response with HTML page containg just image specified in
arguments. *)
val print_placeholder_gendered_portrait : config -> Gwdb.person -> int -> unit
(** prints html `<img>` tag of the default gendered portrait with square
size [size] *)

5
lib/json_export/dune Normal file
View File

@@ -0,0 +1,5 @@
(library
(name geneweb_export)
(public_name geneweb.export)
(libraries unix geneweb_def geneweb_def_show geneweb_gwdb)
(modules json_converter))

242
lib/json_export/json_converter.ml Normal file
View File

@@ -0,0 +1,242 @@
open Def
module type ConverterDriver = sig
type t
val str : string -> t
val int : int -> t
val obj : (string * t) array -> t
val null : t
val array : 't array -> t
val list : 't list -> t
val bool : bool -> t
end
(* e.g. js_of_ocaml *)
(* module ConverterDriver = struct
* type t = Js.Unsafe.any
* let str x = Js.Unsafe.inject @@ Js.string x
* let int x = Js.Unsafe.inject x
* let obj x = Js.Unsafe.inject @@ Js.Unsafe.obj x
* let null = Js.Unsafe.inject Js.null
* let array x = Js.Unsafe.inject @@ Js.array x
* let list x = array (Array.of_list x)
* let bool x = Js.Unsafe.inject @@ if x then Js._true else Js._false
* end *)
(* e.g. yojson *)
(* module ConverterDriver = struct
* type t = Yojson.Basic.t
* let str x = `String x
* let int x = `Int x
* let obj x = `Assoc x
* let null = `Null
* let array x = `List (Array.to_list x)
* let list x = `List x
* let bool x = `Bool x
* end *)
module Make (D : ConverterDriver) = struct
let str = D.str
let int = D.int
let obj = D.obj
let null = D.null
let array = D.array
let list = D.list
let bool = D.bool
let opt fn = function Some x -> fn x | None -> null
(** gwdb to json *)
let conv_dmy dmy =
obj
[|
("day", int dmy.day);
("delta", if dmy.delta = 0 then null else int dmy.delta);
("month", int dmy.month);
("year", int dmy.year);
|]
let conv_dmy2 dmy =
obj
[|
("day", int dmy.day2); ("month", int dmy.month2); ("year", int dmy.year2);
|]
let conv_date_cal dt cal =
let prec =
match dt.prec with
| Sure -> str "Sure"
| About -> str "About"
| Maybe -> str "Maybe"
| Before -> str "Before"
| After -> str "After"
| OrYear _ -> str "OrYear"
| YearInt _ -> str "YearInt"
in
let dmy2 =
match dt.prec with
| OrYear dmy2 -> conv_dmy2 dmy2
| YearInt dmy2 -> conv_dmy2 dmy2
| _ -> null
in
obj
[|
("prec", prec);
("dmy1", conv_dmy dt);
("dmy2", dmy2);
("calendar", str cal);
|]
let conv_date oc =
match oc with
| Dgreg (d, c) -> conv_date_cal d (Def_show.show_calendar c)
| Dtext t -> str t
let conv_cdate cd =
match Date.od_of_cdate cd with None -> null | Some date -> conv_date date
let conv_pevent_name x =
str
@@ Def_show.show_gen_pers_event_name
(fun fmt -> Format.fprintf fmt "Epers_Name %s")
x
let conv_event_witness_kind x = str @@ Def_show.show_witness_kind x
let handler_of_iper i = str @@ Gwdb_driver.string_of_iper i
let handler_of_ifam i = str @@ Gwdb_driver.string_of_ifam i
let conv_event_witness (i, kind) =
obj
[|
("person", handler_of_iper i); ("kind", conv_event_witness_kind kind);
|]
let conv_pevent pevent =
obj
[|
("place", str pevent.epers_place);
("reason", str pevent.epers_reason);
("note", str pevent.epers_note);
("src", str pevent.epers_src);
("name", conv_pevent_name pevent.epers_name);
("date", conv_cdate pevent.epers_date);
( "witnesses",
array @@ Array.map conv_event_witness pevent.epers_witnesses );
|]
let conv_title_name = function
| Tmain -> str ""
| Tname s -> str s
| Tnone -> null
let conv_title gen_title =
obj
[|
("name", conv_title_name gen_title.t_name);
("date_start", conv_cdate gen_title.t_date_start);
("date_end", conv_cdate gen_title.t_date_end);
("nth", int gen_title.t_nth);
("ident", str gen_title.t_ident);
("place", str gen_title.t_place);
|]
let conv_relation_kind x = str @@ Def_show.show_relation_kind x
let conv_fevent_name x =
str
@@ Def_show.show_gen_fam_event_name
(fun fmt -> Format.fprintf fmt "Efam_Name %s")
x
let conv_fevent fevent =
obj
[|
("date", conv_cdate fevent.efam_date);
("name", conv_fevent_name fevent.efam_name);
("note", str fevent.efam_note);
("place", str fevent.efam_place);
("reason", str fevent.efam_reason);
("src", str fevent.efam_src);
( "witnesses",
array @@ Array.map conv_event_witness fevent.efam_witnesses );
|]
let conv_divorce = function
| NotDivorced -> bool false
| Divorced date -> conv_cdate date
| Separated -> bool true
let conv_relation_type x = str @@ Def_show.show_relation_type x
let conv_rparent gen_relation =
obj
[|
("father", opt handler_of_iper gen_relation.r_fath);
("mother", opt handler_of_iper gen_relation.r_moth);
("source", str gen_relation.r_sources);
("type", conv_relation_type gen_relation.r_type);
|]
let conv_death = function
| Def.NotDead -> str "NotDead"
| Death (Killed, _) -> str "Killed"
| Death (Murdered, _) -> str "Murdered"
| Death (Executed, _) -> str "Executed"
| Death (Disappeared, _) -> str "Disappeared"
| Death (Unspecified, _) -> str "Unspecified"
| DeadYoung -> str "DeadYoung"
| DeadDontKnowWhen -> str "DeadDontKnowWhen"
| DontKnowIfDead -> str "DontKnowIfDead"
| OfCourseDead -> str "OfCourseDead"
let conv_person base p =
let pp = Gwdb.gen_person_of_person p in
let pp = Futil.map_person_ps (fun i -> i) (Gwdb.sou base) pp in
let pa = Gwdb.gen_ascend_of_person p in
let pu = Gwdb.gen_union_of_person p in
obj
[|
( "access",
int (match pp.access with Private -> 2 | Public -> 1 | _ -> 0) );
("aliases", list (List.map str pp.aliases));
("first_names_aliases", list (List.map str pp.first_names_aliases));
("firstname", str pp.first_name);
("image", str pp.image);
("iper", handler_of_iper pp.key_index);
("lastname", str pp.surname);
("note", str pp.notes);
("occ", int pp.occ);
("occupation", str pp.occupation);
("parents", opt handler_of_ifam pa.parents);
( "consang",
if pa.consang = Adef.no_consang then null
else int (Adef.fix_repr pa.consang) );
("pevents", list (List.map conv_pevent pp.pevents));
("psources", str pp.psources);
("public_name", str pp.public_name);
("qualifiers", list (List.map str pp.qualifiers));
("related", list (List.map handler_of_iper pp.related));
("rparents", list (List.map conv_rparent pp.rparents));
("sex", int (match pp.sex with Male -> 1 | Female -> 2 | _ -> 0));
("surnames_aliases", list (List.map str pp.surnames_aliases));
("titles", list (List.map conv_title pp.titles));
("unions", list (List.map handler_of_ifam (Array.to_list pu.family)));
|]
let conv_family base f =
let ff = Gwdb.gen_family_of_family f in
let ff = Futil.map_family_ps (fun i -> i) (fun i -> i) (Gwdb.sou base) ff in
let fc = Gwdb.gen_couple_of_family f in
let fd = Gwdb.gen_descend_of_family f in
obj
[|
("fevents", list (List.map conv_fevent ff.fevents));
("comment", str ff.comment);
("origin_file", str ff.origin_file);
("fsources", str ff.fsources);
("witnesses", array (Array.map handler_of_iper ff.witnesses));
("children", array (Array.map handler_of_iper fd.children));
("parents", array (Array.map handler_of_iper @@ Adef.parent_array fc));
|]
end

80
lib/json_export/json_converter.mli Normal file
View File

@@ -0,0 +1,80 @@
(** Json converter driver *)
module type ConverterDriver = sig
type t
(** Json value *)
val str : string -> t
(** Convert to JSON string *)
val int : int -> t
(** Convert to JSON integer *)
val obj : (string * t) array -> t
(** Convert to JSON object *)
val null : t
(** Convert to JSON null value *)
val array : 't array -> t
(** Convert array to JSON list *)
val list : 't list -> t
(** Convert list to JSON list *)
val bool : bool -> t
(** Convert to JSON boolean *)
end
(** Functor building JSON convertion functions of the Geneweb data types. *)
module Make : functor (D : ConverterDriver) -> sig
val conv_dmy : Def.dmy -> D.t
(** Convert [dmy] to JSON *)
val conv_dmy2 : Def.dmy2 -> D.t
(** Convert [dmy2] to JSON *)
val conv_cdate : Def.cdate -> D.t
(** Convert [cdate] to JSON *)
val conv_pevent_name : string Def.gen_pers_event_name -> D.t
(** Convert [gen_pers_event_name] to JSON *)
val conv_event_witness_kind : Def.witness_kind -> D.t
(** Convert [witness_kind] to JSON *)
val conv_pevent : (Gwdb_driver.iper, string) Def.gen_pers_event -> D.t
(** Convert [gen_pers_event] to JSON *)
val conv_title_name : string Def.gen_title_name -> D.t
(** Convert [gen_title_name] to JSON *)
val conv_title : string Def.gen_title -> D.t
(** Convert [gen_title] to JSON *)
val conv_relation_kind : Def.relation_kind -> D.t
(** Convert [relation_kind] to JSON *)
val conv_fevent_name : string Def.gen_fam_event_name -> D.t
(** Convert [gen_fam_event_name] to JSON *)
val conv_fevent : (Gwdb_driver.iper, string) Def.gen_fam_event -> D.t
(** Convert [gen_fam_event] to JSON *)
val conv_divorce : Def.divorce -> D.t
(** Convert [divorce] to JSON *)
val conv_relation_type : Def.relation_type -> D.t
(** Convert [relation_type] to JSON *)
val conv_rparent : (Gwdb_driver.iper, string) Def.gen_relation -> D.t
(** Convert [gen_relation] to JSON *)
val conv_death : Def.death -> D.t
(** Convert [death] to JSON *)
val conv_person : Gwdb.base -> Gwdb.person -> D.t
(** Convert [person] to JSON *)
val conv_family : Gwdb.base -> Gwdb.family -> D.t
(** Convert [family] to JSON *)
end

153
lib/mergeDisplay.ml Normal file
View File

@@ -0,0 +1,153 @@
(* $Id: merge.ml, v7-exp 2018-09-26 07:34:44 ddr Exp $ *)
(* Copyright (c) 1998-2007 INRIA *)
open Config
open Gwdb
open Util
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 conf base p =
let title h =
Output.print_sstring conf
(Utf8.capitalize_fst (transl_decline conf "merge" ""));
if not h then (
Output.print_sstring conf " ";
print_someone conf base p;
Output.print_sstring conf " ";
Output.print_sstring conf (transl_decline conf "with" "");
Output.print_sstring conf (transl conf ":"))
in
let list = Gutil.find_same_name base p in
let list =
List.fold_right
(fun p1 pl -> if get_iper p1 = get_iper p then pl else p1 :: pl)
list []
in
Perso.interp_notempl_with_menu title "perso_header" conf base p;
Output.print_sstring conf "<h2>";
title false;
Output.print_sstring conf "</h2>";
Output.print_sstring conf {|<form method="get" action="|};
Output.print_sstring conf conf.command;
Output.print_sstring conf {|"class="mx-3 mb-3">|};
Util.hidden_env conf;
Util.hidden_input conf "m" (Adef.encoded "MRG_IND");
Util.hidden_input conf "i" (get_iper p |> string_of_iper |> Mutil.encode);
Output.print_sstring conf
"<span class=\"form-row align-items-center\"><span \
class=\"col-auto\"><span class=\"custom-control custom-radio\"><input \
type=\"radio\" class=\"custom-control-input\" name=\"select\" \
id=\"input\" value=\"input\" checked><label \
class=\"custom-control-label\"for=\"input\">";
Output.print_sstring conf (transl conf "any individual in the base");
Output.print_sstring conf
"</label></span></span><span class=\"col-auto\"><input type=\"text\" \
class=\"form-control\" name=\"n\" placeholder=\"";
Output.print_sstring conf (transl_nth conf "first name/first names" 0);
Output.print_sstring conf ".";
Output.print_sstring conf (transl conf "number");
Output.print_sstring conf " ";
Output.print_sstring conf (transl_nth conf "surname/surnames" 0);
Output.print_sstring conf "\" title=\"";
Output.print_sstring conf (transl_nth conf "first name/first names" 0);
Output.print_sstring conf ".";
Output.print_sstring conf (transl conf "number");
Output.print_sstring conf " ";
Output.print_sstring conf (transl_nth conf "surname/surnames" 0);
Output.print_sstring conf
"\" size=\"50\" id=\"inlineinput\" autofocus></span></span>";
if list <> [] then
List.iter
(fun p ->
Output.print_sstring conf "<div class=\"custom-control custom-radio\">";
Output.print_sstring conf
"<input type=\"radio\" class=\"custom-control-input\" \
name=\"select\" id=\"";
Output.print_string conf (get_iper p |> string_of_iper |> Mutil.encode);
Output.print_sstring conf "\" value=\"";
Output.print_string conf (get_iper p |> string_of_iper |> Mutil.encode);
Output.print_sstring conf "\">\n";
Output.print_sstring conf "<label class=\"custom-control-label\" for=\"";
Output.print_string conf (get_iper p |> string_of_iper |> Mutil.encode);
Output.print_sstring conf "\">";
let cop = (Util.child_of_parent conf base p :> string) in
let cop = if cop = "" then "" else ", " ^ cop in
let hbw = (Util.husband_wife conf base p true :> string) in
let hbw = if hbw = "" then "" else ", " ^ hbw in
Output.print_sstring conf
(Printf.sprintf "%s.%d %s%s%s"
(get_first_name p |> sou base)
(get_occ p)
(get_surname p |> sou base)
cop hbw);
Output.print_sstring conf "</label></div>")
list;
Output.print_sstring conf
{|<button type="submit" class="btn btn-primary btn-lg mt-2">|};
Output.print_sstring conf
(Utf8.capitalize_fst (transl_nth conf "validate/delete" 0));
Output.print_sstring conf "</button></form>\n";
Hutil.trailer conf
let print_possible_continue_merging conf base =
let open Adef in
match (p_getenv conf.env "ini1", p_getenv conf.env "ini2") with
| Some ini1, Some ini2 ->
let ini1 = iper_of_string ini1 in
let ini2 = iper_of_string ini2 in
let p1 = poi base ini1 in
let p2 = poi base ini2 in
Output.print_sstring conf {|<p><a href="|};
Output.print_string conf (commd conf);
Output.print_sstring conf {|m=MRG_IND&i=|};
Output.print_string conf (string_of_iper ini1 |> Mutil.encode);
Output.print_sstring conf {|&i2=|};
Output.print_string conf (string_of_iper ini2 |> Mutil.encode);
Output.print_sstring conf {|">|};
Output.print_sstring conf
(Utf8.capitalize_fst (transl conf "continue merging"));
Output.print_sstring conf {|</a> |};
print_someone conf base p1;
Output.print_sstring conf " ";
Output.print_sstring conf (transl_nth conf "and" 0);
Output.print_sstring conf " ";
print_someone conf base p2;
Output.print_sstring conf "</p>"
| _ -> (
match p_getenv conf.env "ip" with
| Some ip ->
let ip = iper_of_string ip in
let s1 =
match p_getenv conf.env "iexcl" with
| Some "" | None -> Adef.encoded ""
| Some s -> "&iexcl=" ^<^ Mutil.encode s
in
let s2 =
match p_getenv conf.env "fexcl" with
| Some "" | None -> Adef.encoded ""
| Some s -> "&fexcl=" ^<^ Mutil.encode s
in
if s1 <^> Adef.encoded "" || s2 <^> Adef.encoded "" then (
let p = poi base ip in
let s = gen_person_text conf base p in
Output.print_sstring conf {|<p><a href="|};
Output.print_string conf (commd conf);
Output.print_sstring conf {|m=MRG_DUP&ip=|};
Output.print_string conf (string_of_iper ip |> Mutil.encode);
Output.print_string conf s1;
Output.print_string conf s2;
Output.print_sstring conf {|">|};
Output.print_sstring conf
(Utf8.capitalize_fst (transl conf "continue merging"));
Output.print_sstring conf {| (|};
Output.print_sstring conf
(transl_a_of_b conf
(transl conf "possible duplications")
(reference conf base p s :> string)
(s :> string));
Output.print_sstring conf {|)</p>|})
| None -> ())

Some files were not shown because too many files have changed in this diff Show More