1(* camlp5r ./pa_html.cmo *) 2(* $Id: history_diff.ml,v 0.01 2012-12-20 14:34:44 flh Exp $ *) 3(* Copyright (c) 1998-2007 INRIA *) 4 5open Config; 6open Def; 7open Gutil; 8open Gwdb; 9open TemplAst; 10open Util; 11 12 13type gen_record = 14 { date : string; 15 wizard : string; 16 gen_p : gen_person iper string; 17 gen_f : list (gen_family iper string); 18 gen_c : list (array iper) } 19; 20 21 22(* Le nom du fichier historique (à partir de la clé personne). *) 23value history_file fn sn occ = 24 let space_to_unders = Mutil.tr ' ' '_' in 25 let f = space_to_unders (Name.lower fn) in 26 let s = space_to_unders (Name.lower sn) in 27 f ^ "." ^ string_of_int occ ^ "." ^ s 28; 29 30(* Le chemin du dossier history_d. *) 31value history_d conf = 32 let path = 33 match p_getenv conf.base_env "history_path" with 34 [ Some path -> path 35 | None -> "" ] 36 in 37 let bname = 38 if Filename.check_suffix conf.bname ".gwb" then conf.bname 39 else conf.bname ^ ".gwb" 40 in 41 List.fold_left 42 Filename.concat path [Util.base_path [] bname; "history_d"] 43; 44 45(* Le chemin du fichier historique dans le dossier history_d. *) 46value history_path conf fname = 47 if String.length fname >= 6 then 48 let dirs = 49 [history_d conf; String.make 1 fname.[0]; String.make 1 fname.[1]] 50 in 51 List.fold_right Filename.concat dirs fname 52 else Filename.concat (history_d conf) fname 53; 54 55(* Créé tous les dossiers intermédiaires. *) 56value create_history_dirs conf fname = 57 if String.length fname >= 6 then 58 let dirs = 59 [history_d conf; String.make 1 fname.[0]; String.make 1 fname.[1]] 60 in 61 Mutil.mkdir_p (List.fold_left Filename.concat "" dirs) 62 else () 63; 64 65 66(* ************************************************************************ *) 67(* [Fonc] write_history_file : config -> string -> gen_record -> unit *) 68(** [Description] : Enregistre la personne dans son fichier historique. 69 [Args] : 70 - fname : le chemin du fichier 71 - gr : le contenu de la personne 72 [Retour] : Néant 73 [Rem] : Non exporté en clair hors de ce module. *) 74(* ************************************************************************ *) 75value write_history_file conf person_file fname gr = 76 (* On créé toujours les dossiers nécessaires (changement de clé ...). *) 77 let () = create_history_dirs conf person_file in 78 let ext_flags = 79 [Open_wronly; Open_append; Open_creat; Open_binary; Open_nonblock] 80 in 81 match 82 try Some (Secure.open_out_gen ext_flags 0o644 fname) 83 with [ Sys_error _ -> None ] 84 with 85 [ Some oc -> do { output_value oc (gr : gen_record); close_out oc } 86 | None -> () ] 87; 88 89 90(* ************************************************************************ *) 91(* [Fonc] make_gen_record : 92 config -> base -> bool -> gen_person -> gen_record *) 93(** [Description] : Crée un gen_record à partir d'une personne. 94 [Args] : 95 - conf : configuratino de la base 96 - base : base de donnée 97 - first : booléen pour savoir si c'est la première entrée de 98 l'historique. Si c'est le cas, on ne connait pas la date de 99 modification, donc on met "environ" une seconde avant. 100 - gen_p : gen_person 101 [Retour] : 102 - gen_record 103 [Rem] : Non exporté en clair hors de ce module. *) 104(* ************************************************************************ *) 105value make_gen_record conf base first gen_p = 106 let (hh, mm, ss) = conf.time in 107 let (hh, mm, ss) = 108 (* On évite les calculs savant pour la date (ss - 1 avec une date *) 109 (* autour de minuit ...). C'est simplement une indication. *) 110 if first then (hh, mm, min 0 ss) else (hh, mm, ss) 111 in 112 let date = 113 Printf.sprintf "%04d-%02d-%02d %02d:%02d:%02d" 114 conf.today.year conf.today.month conf.today.day hh mm ss 115 in 116 let p = poi base gen_p.key_index in 117 let fam = get_family p in 118 (* On fait en sorte qu'il y a une 'bijection' *) 119 (* entre les familles et les enfants. *) 120 let (gen_f, gen_c) = 121 List.fold_right 122 (fun ifam (accu_fam, accu_child) -> 123 let fam = foi base ifam in 124 let children = get_children fam in 125 let gen_f = gen_family_of_family fam in 126 ([Util.string_gen_family base gen_f :: accu_fam], 127 [children :: accu_child])) 128 (Array.to_list fam) ([], []) 129 in 130 { date = date; wizard = conf.user; gen_p = gen_p; 131 gen_f = gen_f; gen_c = gen_c } 132; 133 134 135(* ************************************************************************ *) 136(* [Fonc] record_diff : config -> base -> base_changed -> unit *) 137(** [Description] : Met à jour le fichier historique d'une personne. 138 [Args] : 139 - conf : configuration de la base 140 - base : base de donnée 141 - changed : le type de modification (voir def.mli) 142 [Retour] : Néant 143 [Rem] : Exporté en clair hors de ce module. *) 144(* ************************************************************************ *) 145value record_diff conf base changed = 146 match p_getenv conf.base_env "history_diff" with 147 [ Some "yes" when not conf.manitou -> 148 match changed with 149 [ U_Add_person p -> 150 let person_file = history_file p.first_name p.surname p.occ in 151 let fname = history_path conf person_file in 152 let gr = make_gen_record conf base False p in 153 write_history_file conf person_file fname gr 154 | U_Modify_person o p -> 155 let o_person_file = history_file o.first_name o.surname o.occ in 156 let person_file = history_file p.first_name p.surname p.occ in 157 let ofname = history_path conf o_person_file in 158 let fname = history_path conf person_file in 159 do { 160 (* La clé a changé, on reprend l'ancien historique. *) 161 if o_person_file <> person_file && Sys.file_exists ofname then 162 try Sys.rename ofname fname with [ Sys_error _ -> () ] 163 else (); 164 let gr = make_gen_record conf base False p in 165 if Sys.file_exists fname then 166 write_history_file conf person_file fname gr 167 else do { 168 let o_gr = make_gen_record conf base True o in 169 write_history_file conf person_file fname o_gr; 170 write_history_file conf person_file fname gr; 171 } 172 } 173 | U_Delete_person _ -> () (* Faut-il supprimer l'historique ? *) 174 | U_Merge_person _ o p -> 175 let o_person_file = history_file o.first_name o.surname o.occ in 176 let person_file = history_file p.first_name p.surname p.occ in 177 let fname = history_path conf person_file in 178 let gr = make_gen_record conf base False p in 179 (* La clé a changé avec la fusion, on reprend l'ancien historique. *) 180 if o_person_file <> person_file then do { 181 let ofname = history_path conf o_person_file in 182 try Sys.rename ofname fname with [ Sys_error _ -> () ]; 183 write_history_file conf person_file fname gr 184 } 185 else write_history_file conf person_file fname gr 186 | U_Delete_family p f -> () 187 | U_Add_family p f | U_Modify_family p _ f 188 | U_Merge_family p _ _ f | U_Add_parent p f -> 189 let p_file = history_file p.first_name p.surname p.occ in 190 let p_fname = history_path conf p_file in 191 let cpl = foi base f.fam_index in 192 let isp = Gutil.spouse p.key_index cpl in 193 let sp = poi base isp in 194 let sp_file = 195 history_file 196 (sou base (get_first_name sp)) 197 (sou base (get_surname sp)) 198 (get_occ sp) 199 in 200 let sp_fname = history_path conf sp_file in 201 let gen_sp = gen_person_of_person sp in 202 let gen_sp = Util.string_gen_person base gen_sp in 203 do { 204 let gr = make_gen_record conf base False p in 205 write_history_file conf p_file p_fname gr; 206 let gr = make_gen_record conf base False gen_sp in 207 write_history_file conf sp_file sp_fname gr; 208 (* Création des fichiers pour les enfants ajoutés. *) 209 List.iter 210 (fun ip -> 211 let p = poi base ip in 212 let person_file = 213 history_file 214 (sou base (get_first_name p)) 215 (sou base (get_surname p)) 216 (get_occ p) 217 in 218 let fname = history_path conf person_file in 219 if Sys.file_exists fname then () 220 else 221 let gen_p = gen_person_of_person p in 222 let gen_p = Util.string_gen_person base gen_p in 223 let gr = make_gen_record conf base False gen_p in 224 write_history_file conf person_file fname gr) 225 (Array.to_list (get_children cpl)) 226 } 227 | U_Change_children_name _ list -> 228 List.iter 229 (fun ((ofn, osn, oocc, oip), (fn, sn, occ, ip)) -> 230 let o_person_file = history_file ofn osn oocc in 231 let person_file = history_file fn sn occ in 232 if o_person_file <> person_file then 233 do { 234 let ofname = history_path conf o_person_file in 235 let fname = history_path conf person_file in 236 try Sys.rename ofname fname with [ Sys_error _ -> () ]; 237 let p = poi base ip in 238 let p = 239 Futil.map_person_ps 240 (fun p -> p) (sou base) (gen_person_of_person p) 241 in 242 let gr = make_gen_record conf base False p in 243 write_history_file conf person_file fname gr 244 } 245 else ()) 246 list 247 | U_Multi p -> 248 let person_file = history_file p.first_name p.surname p.occ in 249 let fname = history_path conf person_file in 250 let gr = make_gen_record conf base False p in 251 write_history_file conf person_file fname gr 252 | _ -> () ] 253 | _ -> () ] 254; 255 256 257(* avec zip ? *) 258(* 259 let history = ref [] in 260 let fname = history_path conf fname in 261 if extract_zfile fname then 262 do { 263 read_history_file fname 264 Sys.remove fname 265 } 266 else (); 267 history.val 268*) 269 270(* ************************************************************************ *) 271(* [Fonc] load_person_history : config -> string -> gen_record list *) 272(** [Description] : Charge la liste des modifications pour une personne. 273 L'avantage est que les versions les plus récentes se trouvent en 274 tête de liste. 275 [Args] : 276 - conf : configuration de la base 277 - fname : le nom du fichier historique 278 [Retour] : 279 - gen_record list 280 [Rem] : Non exporté en clair hors de ce module. *) 281(* ************************************************************************ *) 282value load_person_history conf fname = do { 283 let history = ref [] in 284 let fname = history_path conf fname in 285 match try Some (Secure.open_in_bin fname) with [ Sys_error _ -> None ] with 286 [ Some ic -> 287 do { 288 try 289 while True do { 290 let v : gen_record = input_value ic in 291 history.val := [v :: history.val] 292 } 293 with [ End_of_file -> () | Failure "input_value: truncated object" -> () ]; (* https://caml.inria.fr/mantis/view.php?id=7142 *) 294 close_in ic 295 } 296 | None -> () ]; 297 history.val 298}; 299 300 301(* ************************************************************************ *) 302(* [Fonc] print_clean : config -> base -> unit *) 303(** [Description] : 304 [Args] : 305 - conf : configuration de la base 306 - base : base de donnée 307 [Retour] : Néant 308 [Rem] : Exporté en clair hors de ce module. *) 309(* ************************************************************************ *) 310value print_clean conf base = 311 match p_getenv conf.env "f" with 312 [ Some f when f <> "" -> 313 do { 314 let title _ = 315 Wserver.wprint "%s" (capitale (transl conf "clean history")) 316 in 317 Hutil.header conf title; 318 Hutil.print_link_to_welcome conf True; 319 Util.gen_print_tips conf 320 (capitale 321 (transl conf 322 "select the input you want to erase from the history")); 323 let history = load_person_history conf f in 324 tag "form" "method=\"post\" action=\"%s\"" conf.command begin 325 xtag "input" "type=\"hidden\" name=\"m\" value=\"HIST_CLEAN_OK\"" ; 326 xtag "input" "type=\"hidden\" name=\"f\" value=\"%s\"" f; 327 tag "ul" begin 328 loop 0 history where rec loop i = fun 329 [ [] -> () 330 | [gr :: l] -> 331 do { 332 tag "li" begin 333 tag "label" begin 334 xtag "input" "type=\"checkbox\" name=\"i%d\" value=\"on\"" i; 335 Wserver.wprint "%s %s" gr.date gr.wizard; 336 end; 337 end; 338 loop (i + 1) l 339 } ]; 340 end; 341 xtag "input" "type=\"submit\" value=\"Ok\""; 342 end; 343 Hutil.trailer conf 344 } 345 | _ -> Hutil.incorrect_request conf ] 346; 347 348 349(* avec zip ? *) 350(* 351 let history = clean_history in 352 let fname = history_path conf fname in 353 if compress_zfile fname then 354 do { 355 write_history_file fname history; 356 Sys.remove fname 357 } 358 else (); 359*) 360 361(* ************************************************************************ *) 362(* [Fonc] print_clean_ok : config -> base -> unit *) 363(** [Description] : Ré-écrit le fichier historique lié à une personne en 364 ayant supprimé les entrées non désirées. 365 [Args] : 366 - conf : configuration de la base 367 - base : base de donnée 368 [Retour] : Néant 369 [Rem] : Exporté en clair hors de ce module. *) 370(* ************************************************************************ *) 371value print_clean_ok conf base = 372 let rec clean_history i history new_history = 373 match history with 374 [ [] -> new_history 375 | [gr :: l] -> 376 let lab = "i" ^ string_of_int i in 377 if p_getenv conf.env lab = Some "on" then 378 clean_history (i + 1) l new_history 379 else clean_history (i + 1) l [gr :: new_history] ] 380 in 381 match p_getenv conf.env "f" with 382 [ Some f when f <> "" -> 383 do { 384 let title _ = 385 Wserver.wprint "%s" (capitale (transl conf "history cleaned")) 386 in 387 Hutil.header conf title; 388 Hutil.print_link_to_welcome conf True; 389 let history = load_person_history conf f in 390 let new_history = clean_history 0 history [] in 391 let fname = history_path conf f in 392 if new_history = [] then 393 try Sys.remove fname with [ Sys_error _ -> () ] 394 else 395 let ext_flags = 396 [Open_wronly; Open_trunc; Open_creat; Open_binary; Open_nonblock] 397 in 398 match 399 try Some (Secure.open_out_gen ext_flags 0o644 fname) 400 with [ Sys_error _ -> None ] 401 with 402 [ Some oc -> do { 403 List.iter (fun v -> output_value oc (v : gen_record)) new_history; 404 close_out oc } 405 | None -> () ]; 406 Hutil.trailer conf 407 } 408 | _ -> Hutil.incorrect_request conf ] 409; 410 411 412(**/**) (* Template *) 413 414 415value person_of_gen_p_key base gen_p = 416 match person_of_key base gen_p.first_name gen_p.surname gen_p.occ with 417 [ Some ip -> poi base ip 418 | None -> Gwdb.empty_person base (Adef.iper_of_int (-1)) ] 419; 420 421(* N'est pas forcément très précis. En effet, on enregistre que *) 422(* les ipers. Or lors d'un nettoyage de la base, il se peut que *) 423(* ces ipers changent. On peut donc pointer vers une autre persone. *) 424value person_of_iper conf base ip = 425 try 426 let p = pget conf base ip in 427 if authorized_age conf base p then Util.person_text conf base p 428 else "" 429 with _ -> "" 430; 431 432value person_of_iper_list conf base ipl = 433 let list = 434 List.fold_right 435 (fun ip accu -> 436 let p = person_of_iper conf base ip in 437 if p = "" then accu 438 else [p :: accu]) 439 ipl [] 440 in 441 String.concat ", " list 442; 443 444 445value string_of_codate conf cod = 446 match Adef.od_of_codate cod with 447 [ Some d -> Date.string_slash_of_date conf d 448 | None -> "" ] 449; 450 451value string_of_death conf death = 452 match death with 453 [ Death _ cd -> Date.string_slash_of_date conf (Adef.date_of_cdate cd) 454 | _ -> "" ] 455; 456 457value string_of_burial conf burial = 458 match burial with 459 [ Buried cod | Cremated cod -> string_of_codate conf cod 460 | _ -> "" ] 461; 462 463value string_of_title conf titles = 464 let string_of_t_name t = 465 match t.t_name with 466 [ Tname s -> s 467 | _ -> "" ] 468 in 469 let one_title t = 470 let name = t.t_ident ^ " " ^ t.t_place in 471 let name = if name = " " then "" else name in 472 let dates = 473 string_of_codate conf t.t_date_start ^ "-" ^ 474 string_of_codate conf t.t_date_end 475 in 476 let dates = if dates = "-" then "" else "(" ^ dates ^ ")" in 477 let nth = if t.t_nth = 0 then "" else string_of_int t.t_nth in 478 let nth = 479 if string_of_t_name t = "" then nth 480 else string_of_t_name t ^ " " ^ string_of_int t.t_nth 481 in 482 let nth = if nth = "" || nth = " " then "" else "[" ^ nth ^ "]" in 483 name ^ (if name = "" then "" else " ") ^ nth ^ 484 (if nth = "" then "" else " ") ^ dates 485 in 486 List.fold_left 487 (fun accu t -> 488 if accu = "" then one_title t 489 else accu ^ ", " ^ one_title t) 490 "" titles 491; 492 493value string_of_related conf base ip related = 494 let related = 495 List.fold_right 496 (fun ic accu -> 497 let p = person_of_iper conf base ip in 498 if p = "" then accu 499 else 500 (* Si l'enfant n'existe plus. *) 501 let c = try pget conf base ic with _ -> Gwdb.empty_person base ic in 502 let rel = 503 loop (get_rparents c) where rec loop rp = 504 match rp with 505 [ [r :: l] -> 506 match r.r_fath with 507 [ Some ifath when ifath = ip -> 508 Util.rchild_type_text conf r.r_type 2 509 | _ -> loop l ] 510 | [] -> "" ] 511 in 512 [capitale rel ^ ": " ^ p :: accu]) 513 related [] 514 in 515 String.concat ", " related 516; 517 518value string_of_rparents conf base rparents = 519 let rparents = 520 List.fold_right 521 (fun rp accu -> 522 match (rp.r_fath, rp.r_moth) with 523 [ (Some ip1, Some ip2) -> 524 let rel = capitale (Util.relation_type_text conf rp.r_type 2) in 525 let fath = person_of_iper conf base ip1 in 526 let moth = person_of_iper conf base ip2 in 527 match (fath, moth) with 528 [ ("", "") -> accu 529 | (p, "") -> [rel ^ ": " ^ p :: accu] 530 | ("", p) -> [rel ^ ": " ^ p :: accu] 531 | (p1, p2) -> [rel ^ ": " ^ p1 ^ ", " ^ p2 :: accu] ] 532 | (Some ip, None) -> 533 let p = person_of_iper conf base ip in 534 if p = "" then accu 535 else 536 let rel = capitale (Util.relation_type_text conf rp.r_type 2) in 537 [rel ^ ": " ^ p :: accu] 538 | (None, Some ip) -> 539 let p = person_of_iper conf base ip in 540 if p = "" then accu 541 else 542 let rel = capitale (Util.relation_type_text conf rp.r_type 2) in 543 [rel ^ ": " ^ p :: accu] 544 | (None, None) -> accu ]) 545 rparents [] 546 in 547 String.concat ", " rparents 548; 549 550value string_of_marriage conf marriage = 551 match marriage with 552 [ NotMarried | NoSexesCheckNotMarried -> transl conf "with" 553 | Married | NoSexesCheckMarried -> transl conf "married" 554 | Engaged -> transl conf "engaged" 555 | NoMention -> transl conf "with" ] 556; 557 558value string_of_divorce conf divorce = 559 match divorce with 560 [ NotDivorced -> "" 561 | Divorced cod -> transl conf "divorced" ^ " " ^ string_of_codate conf cod 562 | Separated -> transl conf "separated" ] 563; 564 565 566(* ************************************************************************ *) 567(* [Fonc] array_of_string : string -> char array *) 568(** [Description] : Converti une string en tableau de char afin de pouvoir 569 faire un diff. 570 [Args] : 571 - s : string à convertir 572 [Retour] : 573 - char array 574 [Rem] : Non exporté en clair hors de ce module. *) 575(* ************************************************************************ *) 576value array_of_string s = 577 let len = String.length s in 578 let a = Array.make len ' ' in 579 loop 0 where rec loop i = 580 if i = len then a 581 else do { 582 a.(i) := s.[i]; 583 loop (i + 1) 584 } 585; 586 587 588(* ************************************************************************ *) 589(* [Fonc] highlight_diff : char array -> bool array -> string *) 590(** [Description] : Converti un tableau de char en string, avec les parties 591 modifiées encadrées par des balises <span>. 592 [Args] : 593 - arr : tableau à convertir 594 - diff_arr : tableau des différences 595 [Retour] : 596 - string 597 [Rem] : Non exporté en clair hors de ce module. *) 598(* ************************************************************************ *) 599value highlight_diff arr diff_arr = 600 loop 0 "" where rec loop i s = 601 if i >= Array.length arr then s 602 else if diff_arr.(i) then do { 603 let j = ref i in 604 let accu = ref s in 605 accu.val := accu.val ^ "<span class=\"diff_highlight\">"; 606 while j.val < Array.length diff_arr && diff_arr.(j.val) do { 607 accu.val := accu.val ^ Printf.sprintf "%c" arr.(j.val); 608 incr j 609 }; 610 accu.val := accu.val ^ "</span>"; 611 loop j.val accu.val 612 } 613 else 614 loop (i + 1) (s ^ Printf.sprintf "%c" arr.(i)) 615; 616 617 618(* ************************************************************************ *) 619(* [Fonc] diff_string : string -> string -> (string * string) *) 620(** [Description] : Renvoie les deux string avec mise en évidence des 621 différences entre les deux. 622 [Args] : 623 - before : string avant modification 624 - after : string après modification 625 [Retour] : 626 - string * string 627 [Rem] : Non exporté en clair hors de ce module. *) 628(* ************************************************************************ *) 629value diff_string before after = 630 if before = after then (before, after) 631 else if before = "" then 632 (before, "<span class=\"diff_highlight\">" ^ after ^ "</span>") 633 else if after = "" then 634 ("<span class=\"diff_highlight\">" ^ before ^ "</span>", after) 635 else 636 let aa = array_of_string after in 637 let bb = array_of_string before in 638 let (bef_d, aft_d) = Diff.f bb aa in 639 let bef_s = highlight_diff bb bef_d in 640 let aft_s = highlight_diff aa aft_d in 641 (bef_s, aft_s) 642; 643 644 645type env 'a = 646 [ Vgen_record of gen_record 647 | Vfam of option (gen_family iper string) and option (gen_family iper string) and bool 648 | Vchild of option (array iper) and option (array iper) 649 | Vbool of bool 650 | Vint of int 651 | Vstring of string 652 | Vother of 'a 653 | Vnone ] 654; 655 656 657value get_env v env = try List.assoc v env with [ Not_found -> Vnone ]; 658value get_vother = fun [ Vother x -> Some x | _ -> None ]; 659value set_vother x = Vother x; 660value str_val x = VVstring x; 661value bool_val x = VVbool x; 662 663value rec eval_var conf base env (bef, aft, p_auth) loc sl = 664 try eval_simple_var conf base env (bef, aft, p_auth) sl with 665 [ Not_found -> eval_compound_var conf base env (bef, aft, p_auth) sl ] 666and eval_simple_var conf base env (bef, aft, p_auth) = 667 fun 668 [ [s] -> str_val (eval_simple_str_var conf base env (bef, aft, p_auth) s) 669 | _ -> raise Not_found ] 670and eval_compound_var conf base env (bef, aft, p_auth) sl = 671 let rec loop = 672 fun 673 [ [s] -> eval_simple_str_var conf base env (bef, aft, p_auth) s 674 | ["evar"; s] -> 675 match p_getenv conf.env s with 676 [ Some s -> s 677 | None -> "" ] 678 | ["before" :: sl] -> 679 fst (eval_gen_record conf base env (bef, aft, p_auth) sl) 680 | ["after" :: sl] -> 681 snd (eval_gen_record conf base env (bef, aft, p_auth) sl) 682 | _ -> raise Not_found ] 683 in 684 str_val (loop sl) 685and eval_gen_record conf base env (bef, aft, p_auth) = 686 fun 687 [ ["date"] -> (bef.date, aft.date) 688 | ["wizard"] -> (bef.wizard, aft.wizard) 689 | [s] -> eval_str_gen_record conf base env (bef, aft, p_auth) s 690 | _ -> raise Not_found ] 691and eval_str_gen_record conf base env (bef, aft, p_auth) = 692 fun 693 [ "first_name" -> 694 if p_auth then 695 let b = bef.gen_p.first_name in 696 let a = aft.gen_p.first_name in 697 diff_string b a 698 else ("", "") 699 | "surname" -> 700 if p_auth then 701 let b = bef.gen_p.surname in 702 let a = aft.gen_p.surname in 703 diff_string b a 704 else ("", "") 705 | "occ" -> 706 if p_auth then 707 let b = string_of_int bef.gen_p.occ in 708 let a = string_of_int aft.gen_p.occ in 709 diff_string b a 710 else ("", "") 711 | "image" -> 712 if p_auth && not conf.no_image then 713 let b = bef.gen_p.image in 714 let a = aft.gen_p.image in 715 diff_string b a 716 else ("", "") 717 | "public_name" -> 718 if p_auth then 719 let b = bef.gen_p.public_name in 720 let a = aft.gen_p.public_name in 721 diff_string b a 722 else ("", "") 723 | "qualifiers" -> 724 if p_auth then 725 let b = String.concat ", " bef.gen_p.qualifiers in 726 let a = String.concat ", " aft.gen_p.qualifiers in 727 diff_string b a 728 else ("", "") 729 | "aliases" -> 730 if p_auth then 731 let b = String.concat ", " bef.gen_p.aliases in 732 let a = String.concat ", " aft.gen_p.aliases in 733 diff_string b a 734 else ("", "") 735 | "first_names_aliases" -> 736 if p_auth then 737 let b = String.concat ", " bef.gen_p.first_names_aliases in 738 let a = String.concat ", " aft.gen_p.first_names_aliases in 739 diff_string b a 740 else ("", "") 741 | "surnames_aliases" -> 742 if p_auth then 743 let b = String.concat ", " bef.gen_p.surnames_aliases in 744 let a = String.concat ", " aft.gen_p.surnames_aliases in 745 diff_string b a 746 else ("", "") 747 | "titles" -> 748 if p_auth then 749 let b = string_of_title conf bef.gen_p.titles in 750 let a = string_of_title conf aft.gen_p.titles in 751 diff_string b a 752 else ("", "") 753 | "relations" -> 754 if p_auth then 755 let br = 756 string_of_related conf base bef.gen_p.key_index bef.gen_p.related 757 in 758 let ar = 759 string_of_related conf base aft.gen_p.key_index aft.gen_p.related 760 in 761 let brp = string_of_rparents conf base bef.gen_p.rparents in 762 let arp = string_of_rparents conf base aft.gen_p.rparents in 763 let b = if br = "" then brp else (br ^ ". " ^ brp) in 764 let a = if ar = "" then arp else (ar ^ ". " ^ brp) in 765 diff_string b a 766 else ("", "") 767 | "occupation" -> 768 if p_auth then 769 let b = bef.gen_p.occupation in 770 let a = aft.gen_p.occupation in 771 diff_string b a 772 else ("", "") 773 | "sex" -> 774 if p_auth then 775 let b = 776 transl_nth 777 conf "male/female/neuter" (Util.index_of_sex bef.gen_p.sex) 778 in 779 let a = 780 transl_nth 781 conf "male/female/neuter" (Util.index_of_sex aft.gen_p.sex) 782 in 783 diff_string b a 784 else ("", "") 785 | "access" -> 786 if p_auth then 787 let b = 788 match bef.gen_p.access with 789 [ IfTitles -> transl_nth conf "iftitles/public/private" 0 790 | Public -> transl_nth conf "iftitles/public/private" 1 791 | Private -> transl_nth conf "iftitles/public/private" 2 ] 792 in 793 let a = 794 match aft.gen_p.access with 795 [ IfTitles -> transl_nth conf "iftitles/public/private" 0 796 | Public -> transl_nth conf "iftitles/public/private" 1 797 | Private -> transl_nth conf "iftitles/public/private" 2 ] 798 in 799 diff_string b a 800 else ("", "") 801 | "birth" -> 802 if p_auth then 803 let b = string_of_codate conf bef.gen_p.birth in 804 let a = string_of_codate conf aft.gen_p.birth in 805 diff_string b a 806 else ("", "") 807 | "birth_place" -> 808 if p_auth then 809 let b = bef.gen_p.birth_place in 810 let a = aft.gen_p.birth_place in 811 diff_string b a 812 else ("", "") 813 | "birth_src" -> 814 if p_auth then 815 let b = bef.gen_p.birth_src in 816 let a = aft.gen_p.birth_src in 817 diff_string b a 818 else ("", "") 819 | "baptism" -> 820 if p_auth then 821 let b = string_of_codate conf bef.gen_p.baptism in 822 let a = string_of_codate conf aft.gen_p.baptism in 823 diff_string b a 824 else ("", "") 825 | "baptism_place" -> 826 if p_auth then 827 let b = bef.gen_p.baptism_place in 828 let a = aft.gen_p.baptism_place in 829 diff_string b a 830 else ("", "") 831 | "baptism_src" -> 832 if p_auth then 833 let b = bef.gen_p.baptism_src in 834 let a = aft.gen_p.baptism_src in 835 diff_string b a 836 else ("", "") 837 | "death" -> 838 if p_auth then 839 let b = string_of_death conf bef.gen_p.death in 840 let a = string_of_death conf aft.gen_p.death in 841 diff_string b a 842 else ("", "") 843 | "death_place" -> 844 if p_auth then 845 let b = bef.gen_p.death_place in 846 let a = aft.gen_p.death_place in 847 diff_string b a 848 else ("", "") 849 | "death_src" -> 850 if p_auth then 851 let b = bef.gen_p.death_src in 852 let a = aft.gen_p.death_src in 853 diff_string b a 854 else ("", "") 855 | "burial" -> 856 if p_auth then 857 let b = string_of_burial conf bef.gen_p.burial in 858 let a = string_of_burial conf aft.gen_p.burial in 859 diff_string b a 860 else ("", "") 861 | "burial_place" -> 862 if p_auth then 863 let b = bef.gen_p.burial_place in 864 let a = aft.gen_p.burial_place in 865 diff_string b a 866 else ("", "") 867 | "burial_src" -> 868 if p_auth then 869 let b = bef.gen_p.burial_src in 870 let a = aft.gen_p.burial_src in 871 diff_string b a 872 else ("", "") 873 | "notes" -> 874 if p_auth && not conf.no_note then 875 let b = bef.gen_p.notes in 876 let a = aft.gen_p.notes in 877 diff_string b a 878 else ("", "") 879 | "psources" -> 880 if p_auth then 881 let b = bef.gen_p.psources in 882 let a = aft.gen_p.psources in 883 diff_string b a 884 else ("", "") 885 | "spouse" -> 886 match get_env "fam" env with 887 [ Vfam f_bef f_aft m_auth -> 888 if m_auth then 889 (eval_string_env "spouse_bef" env, 890 eval_string_env "spouse_aft" env) 891 else ("", "") 892 | _ -> raise Not_found ] 893 | "marriage" -> 894 match get_env "fam" env with 895 [ Vfam bef aft m_auth -> 896 if m_auth then 897 match (bef, aft) with 898 [ (Some b, Some a) -> 899 let b = string_of_codate conf b.marriage in 900 let a = string_of_codate conf a.marriage in 901 diff_string b a 902 | (None, Some a) -> ("", string_of_codate conf a.marriage) 903 | (Some b, None) -> (string_of_codate conf b.marriage, "") 904 | (None, None) -> ("", "") ] 905 else ("", "") 906 | _ -> raise Not_found ] 907 | "marriage_place" -> 908 match get_env "fam" env with 909 [ Vfam bef aft m_auth -> 910 if m_auth then 911 match (bef, aft) with 912 [ (Some b, Some a) -> 913 let b = b.marriage_place in 914 let a = a.marriage_place in 915 diff_string b a 916 | (None, Some a) -> ("", a.marriage_place) 917 | (Some b, None) -> (b.marriage_place, "") 918 | (None, None) -> ("", "") ] 919 else ("", "") 920 | _ -> raise Not_found ] 921 | "marriage_src" -> 922 match get_env "fam" env with 923 [ Vfam bef aft m_auth -> 924 if m_auth then 925 match (bef, aft) with 926 [ (Some b, Some a) -> 927 let b = b.marriage_src in 928 let a = a.marriage_src in 929 diff_string b a 930 | (None, Some a) -> ("", a.marriage_src) 931 | (Some b, None) -> (b.marriage_src, "") 932 | (None, None) -> ("", "") ] 933 else ("", "") 934 | _ -> raise Not_found ] 935 | "witnesses" -> 936 match get_env "fam" env with 937 [ Vfam bef aft m_auth -> 938 if m_auth then 939 match (bef, aft) with 940 [ (Some b, Some a) -> 941 let b = 942 person_of_iper_list conf base (Array.to_list b.witnesses) 943 in 944 let a = 945 person_of_iper_list conf base (Array.to_list a.witnesses) 946 in 947 diff_string b a 948 | (None, Some a) -> 949 ("", person_of_iper_list conf base (Array.to_list a.witnesses)) 950 | (Some b, None) -> 951 (person_of_iper_list conf base (Array.to_list b.witnesses), "") 952 | (None, None) -> ("", "") ] 953 else ("", "") 954 | _ -> raise Not_found ] 955 | "marriage_type" -> 956 match get_env "fam" env with 957 [ Vfam bef aft m_auth -> 958 if m_auth then 959 match (bef, aft) with 960 [ (Some b, Some a) -> 961 let b = string_of_marriage conf b.relation in 962 let a = string_of_marriage conf a.relation in 963 diff_string b a 964 | (None, Some a) -> ("", string_of_marriage conf a.relation) 965 | (Some b, None) -> (string_of_marriage conf b.relation, "") 966 | (None, None) -> ("", "") ] 967 else ("", "") 968 | _ -> raise Not_found ] 969 | "divorce" -> 970 match get_env "fam" env with 971 [ Vfam bef aft m_auth -> 972 if m_auth then 973 match (bef, aft) with 974 [ (Some b, Some a) -> 975 let b = string_of_divorce conf b.divorce in 976 let a = string_of_divorce conf a.divorce in 977 diff_string b a 978 | (None, Some a) -> ("", string_of_divorce conf a.divorce) 979 | (Some b, None) -> (string_of_divorce conf b.divorce, "") 980 | (None, None) -> ("", "") ] 981 else ("", "") 982 | _ -> raise Not_found ] 983 | "comment" -> 984 match get_env "fam" env with 985 [ Vfam bef aft m_auth -> 986 if m_auth && not conf.no_note then 987 match (bef, aft) with 988 [ (Some b, Some a) -> 989 let b = b.comment in 990 let a = a.comment in 991 diff_string b a 992 | (None, Some a) -> ("", a.comment) 993 | (Some b, None) -> (b.comment, "") 994 | (None, None) -> ("", "") ] 995 else ("", "") 996 | _ -> raise Not_found ] 997 | "origin_file" -> 998 match get_env "fam" env with 999 [ Vfam bef aft m_auth -> 1000 if m_auth then 1001 match (bef, aft) with 1002 [ (Some b, Some a) -> 1003 let b = b.origin_file in 1004 let a = a.origin_file in 1005 diff_string b a 1006 | (None, Some a) -> ("", a.origin_file) 1007 | (Some b, None) -> (b.origin_file, "") 1008 | (None, None) -> ("", "") ] 1009 else ("", "") 1010 | _ -> raise Not_found ] 1011 | "fsources" -> 1012 match get_env "fam" env with 1013 [ Vfam bef aft m_auth -> 1014 if m_auth then 1015 match (bef, aft) with 1016 [ (Some b, Some a) -> 1017 let b = b.fsources in 1018 let a = a.fsources in 1019 diff_string b a 1020 | (None, Some a) -> ("", a.fsources) 1021 | (Some b, None) -> (b.fsources, "") 1022 | (None, None) -> ("", "") ] 1023 else ("", "") 1024 | _ -> raise Not_found ] 1025 | "children" -> 1026 match get_env "fam" env with 1027 [ Vfam _ _ m_auth -> 1028 if m_auth then 1029 match get_env "child" env with 1030 [ Vchild bef aft -> 1031 match (bef, aft) with 1032 [ (Some b, Some a) -> 1033 let b = person_of_iper_list conf base (Array.to_list b) in 1034 let a = person_of_iper_list conf base (Array.to_list a) in 1035 diff_string b a 1036 | (None, Some a) -> 1037 ("", person_of_iper_list conf base (Array.to_list a)) 1038 | (Some b, None) -> 1039 (person_of_iper_list conf base (Array.to_list b), "") 1040 | (None, None) -> ("", "") ] 1041 | _ -> raise Not_found ] 1042 else ("", "") 1043 | _ -> raise Not_found ] 1044 | _ -> raise Not_found ] 1045and eval_simple_str_var conf base env (bef, aft, p_auth) = 1046 fun 1047 [ "acces" -> 1048 let p = person_of_gen_p_key base aft.gen_p in 1049 acces conf base p 1050 | "date" -> eval_string_env "date" env 1051 | "history_len" -> eval_int_env "history_len" env 1052 | "line" -> eval_int_env "line" env 1053 | "nb_families" -> 1054 let nb_fam = max (List.length bef.gen_f) (List.length aft.gen_f) in 1055 string_of_int nb_fam 1056 | "person" -> 1057 if p_auth then 1058 let p = person_of_gen_p_key base aft.gen_p in 1059 Util.person_text conf base p 1060 else eval_string_env "history_file" env 1061 | "wizard" -> eval_string_env "wizard" env 1062 | _ -> raise Not_found ] 1063and eval_string_env s env = 1064 match get_env s env with 1065 [ Vstring s -> s 1066 | _ -> raise Not_found ] 1067and eval_int_env s env = 1068 match get_env s env with 1069 [ Vint i -> string_of_int i 1070 | _ -> raise Not_found ] 1071; 1072 1073value print_foreach conf base print_ast eval_expr = 1074 let rec print_foreach env xx loc s sl el al = 1075 match [s :: sl] with 1076 [ ["family"] -> print_foreach_family env xx el al 1077 | ["history_line"] -> print_foreach_history_line env xx el al 1078 | _ -> raise Not_found ] 1079 and print_foreach_family env xx el al = 1080 let (bef, aft, p_auth) = xx in 1081 let rec loop bef_f bef_c aft_f aft_c = 1082 match (bef_f, aft_f) with 1083 [ ([], []) -> () 1084 | ([], [gen_f :: l]) -> 1085 do { 1086 let fam = foi base gen_f.fam_index in 1087 let isp = Gutil.spouse aft.gen_p.key_index fam in 1088 let sp = person_of_iper conf base isp in 1089 let m_auth = authorized_age conf base (poi base isp) && p_auth in 1090 let vfam = Vfam None (Some gen_f) m_auth in 1091 let (vchild, c) = 1092 match (bef_c, aft_c) with 1093 [ ([], [gen_c :: l]) -> (Vchild None (Some gen_c), l) 1094 | _ -> (* pas normal*) (Vchild None None, []) ] 1095 in 1096 let env = 1097 [("fam", vfam); ("spouse_bef", Vstring ""); 1098 ("spouse_aft", Vstring sp); ("child", vchild) :: env] 1099 in 1100 List.iter (print_ast env xx) al; 1101 loop [] bef_c l c 1102 } 1103 | ([gen_f :: l], []) -> 1104 do { 1105 let fam = foi base gen_f.fam_index in 1106 let isp = Gutil.spouse aft.gen_p.key_index fam in 1107 let sp = person_of_iper conf base isp in 1108 let m_auth = authorized_age conf base (poi base isp) && p_auth in 1109 let vfam = Vfam (Some gen_f) None m_auth in 1110 let (vchild, c) = 1111 match (bef_c, aft_c) with 1112 [ ([gen_c :: l], []) -> (Vchild (Some gen_c) None, l) 1113 | _ -> (* pas normal*) (Vchild None None, []) ] 1114 in 1115 let env = 1116 [("fam", vfam); ("spouse_bef", Vstring sp); 1117 ("spouse_aft", Vstring ""); ("child", vchild) :: env] 1118 in 1119 List.iter (print_ast env xx) al; 1120 loop l c [] aft_c 1121 } 1122 | ([gen_f1 :: l1], [gen_f2 :: l2]) -> 1123 do { 1124 let fam = foi base gen_f2.fam_index in 1125 let isp1 = Gutil.spouse bef.gen_p.key_index fam in 1126 let isp2 = Gutil.spouse aft.gen_p.key_index fam in 1127 let sp1 = person_of_iper conf base isp1 in 1128 let sp2 = person_of_iper conf base isp2 in 1129 let m_auth = authorized_age conf base (poi base isp2) && p_auth in 1130 let vfam = Vfam (Some gen_f1) (Some gen_f2) m_auth in 1131 let (vchild, c1, c2) = 1132 match (bef_c, aft_c) with 1133 [ ([gen_c1 :: l1], [gen_c2 :: l2]) -> 1134 (Vchild (Some gen_c1) (Some gen_c2), l1, l2) 1135 | _ -> (* pas normal*) (Vchild None None, [], []) ] 1136 in 1137 let env = 1138 [("fam", vfam); ("spouse_bef", Vstring sp1); 1139 ("spouse_aft", Vstring sp2); ("child", vchild) :: env] 1140 in 1141 List.iter (print_ast env xx) al; 1142 loop l1 c1 l2 c2 1143 } ] 1144 in 1145 loop bef.gen_f bef.gen_c aft.gen_f aft.gen_c 1146 and print_foreach_history_line env xx el al = 1147 match get_env "history_file" env with 1148 [ Vstring fname -> 1149 let history = load_person_history conf fname in 1150 loop 0 history where rec loop i list = 1151 match list with 1152 [ [] -> () 1153 | [gr :: l] -> 1154 let env = 1155 [("line", Vint i); ("date", Vstring gr.date); 1156 ("wizard", Vstring gr.wizard) :: env] 1157 in 1158 do { List.iter (print_ast env xx) al; loop (i + 1) l } ] 1159 | _ -> () ] 1160 in 1161 print_foreach 1162; 1163 1164value eval_predefined_apply conf env f vl = 1165 let vl = List.map (fun [ VVstring s -> s | _ -> raise Not_found ]) vl in 1166 match (f, vl) with 1167 [ ("transl_date", [date_txt]) -> 1168 (* date_tpl = "0000-00-00 00:00:00" *) 1169 try 1170 let year = int_of_string (String.sub date_txt 0 4) in 1171 let month = int_of_string (String.sub date_txt 5 2) in 1172 let day = int_of_string (String.sub date_txt 8 2) in 1173 let date = 1174 Dgreg 1175 {day = day; month = month; year = year; prec = Sure; delta = 0} 1176 Dgregorian 1177 in 1178 let time = String.sub date_txt 11 8 in 1179 Date.string_of_date conf date ^ ", " ^ time 1180 with [ Failure "int_of_string" -> date_txt ] 1181 | _ -> raise Not_found ] 1182; 1183 1184value print conf base = 1185 match p_getenv conf.env "t" with 1186 [ Some ("SUM" | "DIFF") -> 1187 match p_getenv conf.env "f" with 1188 [ Some file when file <> "" -> 1189 let history = load_person_history conf file in 1190 let len = List.length history in 1191 let (before, after) = 1192 match (p_getint conf.env "old", p_getint conf.env "new") with 1193 [ (Some o, Some n) -> 1194 let o = 1195 if o < 0 then 0 else if o > len - 1 then len - 1 else o 1196 in 1197 let n = 1198 if n < 0 then 0 else if n > len - 1 then len - 1 else n 1199 in 1200 (o, n) 1201 | _ -> (0, 0) ] 1202 in 1203 let before = List.nth history before in 1204 let after = List.nth history after in 1205 let p = person_of_gen_p_key base after.gen_p in 1206 let p_auth = authorized_age conf base p in 1207 let env = 1208 [("history_file", Vstring file); ("history_len", Vint len)] 1209 in 1210 Hutil.interp conf base "updhist_diff" 1211 {Templ.eval_var = eval_var conf base; 1212 Templ.eval_transl _ = Templ.eval_transl conf; 1213 Templ.eval_predefined_apply = eval_predefined_apply conf; 1214 Templ.get_vother = get_vother; Templ.set_vother = set_vother; 1215 Templ.print_foreach = print_foreach conf base} 1216 env (before, after, p_auth) 1217 | _ -> Hutil.incorrect_request conf ] 1218 | _ -> Hutil.incorrect_request conf ] 1219; 1220