293 lines
11 KiB
OCaml
293 lines
11 KiB
OCaml
(* 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
|