1(* camlp5r ./pa_lock.cmo *) 2(* $Id: mk_consang.ml,v 5.56 2012-01-18 21:03:02 ddr Exp $ *) 3(* Copyright (c) 1998-2007 INRIA *) 4 5open Printf; 6 7value fname = ref ""; 8value indexes = ref False; 9value scratch = ref False; 10value quiet = ref False; 11value tlim = ref (-1); 12 13value errmsg = "usage: " ^ Sys.argv.(0) ^ " [options] <file_name>"; 14value speclist = 15 [("-q", Arg.Set quiet, ": quiet mode"); 16 ("-i", Arg.Set indexes, ": build the indexes again"); 17 ("-t", Arg.Int (fun i -> tlim.val := i), " <int>: time limit in seconds"); 18 ("-scratch", Arg.Set scratch, ": from scratch"); 19 ("-mem", Arg.Set Outbase.save_mem, 20 ": Save memory, but slower when rewritting database"); 21 ("-nolock", Arg.Set Lock.no_lock_flag, ": do not lock database.")] 22; 23value anonfun s = 24 if fname.val = "" then fname.val := s 25 else raise (Arg.Bad "Cannot treat several databases") 26; 27 28value rebuild_field_array db2 len pad bdir compress f = do { 29 if Mutil.verbose.val then do { 30 eprintf "rebuilding %s..." (Filename.basename bdir); 31 flush stderr; 32 } 33 else (); 34 if compress then 35 Db2out.output_value_array_compress bdir "" len pad f 36 else 37 Db2out.output_value_array_no_compress bdir "" len pad f; 38 if Mutil.verbose.val then do { 39 eprintf "\n"; 40 flush stderr 41 } 42 else () 43}; 44 45type field_info 'index 'item = 46 { fi_nb : int; 47 fi_ht : Hashtbl.t 'index 'item; 48 fi_index_of_int : int -> 'index; 49 fi_dir : string } 50; 51 52value rebuild_any_field_array db2 fi pad compress (f2, get) = do { 53 let f1 = fi.fi_dir in 54 let bdir = 55 List.fold_left Filename.concat db2.Db2disk.bdir2 ["new_d"; f1; f2] 56 in 57 Mutil.mkdir_p bdir; 58 rebuild_field_array db2 fi.fi_nb pad bdir compress 59 (fun oc_acc output_item -> do { 60 (* put pad as 1st elem; not necessary, just for beauty *) 61 if compress then ignore (output_item pad : int) else (); 62 for i = 0 to fi.fi_nb - 1 do { 63 let x = 64 try get (Hashtbl.find fi.fi_ht (fi.fi_index_of_int i)) with 65 [ Not_found -> 66 let pos = Db2disk.get_field_acc db2 i (f1, f2) in 67 Db2disk.get_field_data db2 pos (f1, f2) "data" ] 68 in 69 let pos = output_item x in 70 output_binary_int oc_acc pos; 71 } 72 }) 73}; 74 75value rebuild_option_field_array db2 fi pad (f2, get) = do { 76 let f1 = fi.fi_dir in 77 let bdir = 78 List.fold_left Filename.concat db2.Db2disk.bdir2 ["new_d"; f1; f2] 79 in 80 Mutil.mkdir_p bdir; 81 rebuild_field_array db2 fi.fi_nb pad bdir True 82 (fun oc_acc output_item -> 83 for i = 0 to fi.fi_nb - 1 do { 84 let x = 85 try get (Hashtbl.find fi.fi_ht (fi.fi_index_of_int i)) with 86 [ Not_found -> 87 let pos = Db2disk.get_field_acc db2 i (f1, f2) in 88 if pos = -1 then None 89 else Some (Db2disk.get_field_data db2 pos (f1, f2) "data") ] 90 in 91 match x with 92 [ None -> output_binary_int oc_acc (-1) 93 | Some x -> do { 94 let pos = output_item x in 95 output_binary_int oc_acc pos 96 } ]; 97 }) 98}; 99 100value rebuild_list_field_array db2 fi (f2, get) = do { 101 let f1 = fi.fi_dir in 102 let f oc_acc oc_dat = 103 for i = 0 to fi.fi_nb - 1 do { 104 let x = 105 try get (Hashtbl.find fi.fi_ht (fi.fi_index_of_int i)) with 106 [ Not_found -> 107 let pos = Db2disk.get_field_acc db2 i (f1, f2) in 108 if pos = -1 then [] 109 else Db2disk.get_field_data db2 pos (f1, f2) "data" ] 110 in 111 if x = [] then output_binary_int oc_acc (-1) 112 else do { 113 let pos = pos_out oc_dat in 114 Iovalue.output oc_dat x; 115 output_binary_int oc_acc pos 116 } 117 } 118 in 119 let bdir = 120 List.fold_left Filename.concat db2.Db2disk.bdir2 ["new_d"; f1; f2] 121 in 122 Mutil.mkdir_p bdir; 123 124 if Mutil.verbose.val then do { 125 eprintf "rebuilding %s..." (Filename.basename bdir); 126 flush stderr; 127 } 128 else (); 129 let oc_dat = open_out_bin (Filename.concat bdir "data") in 130 let oc_acc = open_out_bin (Filename.concat bdir "access") in 131 f oc_acc oc_dat; 132 close_out oc_acc; 133 close_out oc_dat; 134 if Mutil.verbose.val then do { 135 eprintf "\n"; 136 flush stderr 137 } 138 else () 139}; 140 141value rebuild_list2_field_array db2 fi (f2, get) = do { 142 let f1 = fi.fi_dir in 143 let f oc_acc oc_dat = 144 for i = 0 to fi.fi_nb - 1 do { 145 let rxl = 146 try get (Hashtbl.find fi.fi_ht (fi.fi_index_of_int i)) with 147 [ Not_found -> 148 let pos = Db2disk.get_field_acc db2 i (f1, f2) in 149 loop [] pos where rec loop list pos = 150 if pos = -1 then list 151 else 152 let (x, pos) = 153 Db2disk.get_field_2_data db2 pos (f1, f2) "data" 154 in 155 loop [x :: list] pos ] 156 in 157 let pos = 158 loop (-1) rxl where rec loop pos = 159 fun 160 [ [] -> pos 161 | [x :: xl] -> do { 162 let new_pos = pos_out oc_dat in 163 Iovalue.output oc_dat x; 164 Iovalue.output oc_dat pos; 165 loop new_pos xl 166 } ] 167 in 168 output_binary_int oc_acc pos; 169 } 170 in 171 let bdir = 172 List.fold_left Filename.concat db2.Db2disk.bdir2 ["new_d"; f1; f2] 173 in 174 Mutil.mkdir_p bdir; 175 176 if Mutil.verbose.val then do { 177 eprintf "rebuilding %s..." (Filename.basename bdir); 178 flush stderr; 179 } 180 else (); 181 let oc_dat = open_out_bin (Filename.concat bdir "data") in 182 let oc_acc = open_out_bin (Filename.concat bdir "access") in 183 f oc_acc oc_dat; 184 close_out oc_acc; 185 close_out oc_dat; 186 if Mutil.verbose.val then do { 187 eprintf "\n"; 188 flush stderr 189 } 190 else () 191 192}; 193 194value rebuild_string_field db2 fi (f2, get) = do { 195 let f1 = fi.fi_dir in 196 let bdir = 197 List.fold_left Filename.concat db2.Db2disk.bdir2 ["new_d"; f1; f2] 198 in 199 Mutil.mkdir_p bdir; 200 rebuild_field_array db2 fi.fi_nb "" bdir True 201 (fun oc_acc output_item -> do { 202 for i = 0 to fi.fi_nb - 1 do { 203 let s = 204 try get (Hashtbl.find fi.fi_ht (fi.fi_index_of_int i)) with 205 [ Not_found -> 206 let pos = Db2disk.get_field_acc db2 i (f1, f2) in 207 Db2disk.string_of_istr2 db2 (f1, f2) pos ] 208 in 209 let pos = output_item s in 210 output_binary_int oc_acc pos; 211 }; 212 }) 213}; 214 215value rebuild_list_with_string_field_array g h db2 fi (f2, get) = do { 216 let f1 = fi.fi_dir in 217 let bdir = 218 List.fold_left Filename.concat db2.Db2disk.bdir2 ["new_d"; f1; f2] 219 in 220 Mutil.mkdir_p bdir; 221 let oc_ext = open_out_bin (Filename.concat bdir "data2.ext") in 222 rebuild_field_array db2 fi.fi_nb "" bdir True 223 (fun oc_acc output_item -> do { 224 for i = 0 to fi.fi_nb - 1 do { 225 let sl = 226 try get (Hashtbl.find fi.fi_ht (fi.fi_index_of_int i)) with 227 [ Not_found -> 228 let list : list 'a = 229 let pos = Db2disk.get_field_acc db2 i (f1, f2) in 230 if pos = -1 then [] 231 else Db2disk.get_field_data db2 pos (f1, f2) "data2.ext" 232 in 233 List.map (g (Db2disk.string_of_istr2 db2 (f1, f2))) list ] 234 in 235 let pl = List.map (h output_item) sl in 236 if pl = [] then output_binary_int oc_acc (-1) 237 else do { 238 output_binary_int oc_acc (pos_out oc_ext); 239 let (s32, s64) = (Iovalue.size_32.val, Iovalue.size_64.val) in 240 Iovalue.output oc_ext (pl : list 'a); 241 Iovalue.size_32.val := s32; 242 Iovalue.size_64.val := s64; 243 } 244 } 245 }); 246 close_out oc_ext; 247}; 248 249value unique_key_string (ht, scnt) s = 250 let s = Name.lower (Mutil.nominative s) in 251 try Hashtbl.find ht s with 252 [ Not_found -> do { 253 let istr = Adef.istr_of_int scnt.val in 254 Hashtbl.add ht s istr; 255 incr scnt; 256 istr 257 } ] 258; 259 260value make_key_index db2 nb_per bdir = do { 261 if Mutil.verbose.val then do { 262 eprintf "key index..."; 263 flush stderr; 264 } 265 else (); 266 267 let person_of_key_d = Filename.concat bdir "person_of_key" in 268 try Mutil.mkdir_p person_of_key_d with _ -> (); 269 let ht_index_of_key = Hashtbl.create 1 in 270 let ht_strings = (Hashtbl.create 1, ref 0) in 271 272 let f1f2_fn = (Filename.concat "new_d" "person", "first_name") in 273 let f1f2_sn = (Filename.concat "new_d" "person", "surname") in 274 let f1f2_oc = (Filename.concat "new_d" "person", "occ") in 275 for i = 0 to nb_per - 1 do { 276 let fn = 277 let pos = Db2disk.get_field_acc db2 i f1f2_fn in 278 Db2disk.string_of_istr2 db2 f1f2_fn pos 279 in 280 assert (Obj.tag (Obj.repr fn) = Obj.string_tag); 281 let sn = 282 let pos = Db2disk.get_field_acc db2 i f1f2_sn in 283 Db2disk.string_of_istr2 db2 f1f2_sn pos 284 in 285 assert (Obj.tag (Obj.repr sn) = Obj.string_tag); 286 if fn = "?" || sn = "?" then () 287 else 288 let fn = unique_key_string ht_strings fn in 289 let sn = unique_key_string ht_strings sn in 290 let oc = Db2disk.get_field db2 i f1f2_oc in 291 Hashtbl.add ht_index_of_key (Db2.key2_of_key (fn, sn, oc)) 292 (Adef.iper_of_int i); 293 }; 294 295 Db2out.output_hashtbl person_of_key_d "iper_of_key.ht" 296 (ht_index_of_key : Hashtbl.t Db2.key2 Def.iper); 297 Hashtbl.clear ht_index_of_key; 298 299 Db2out.output_hashtbl person_of_key_d "istr_of_string.ht" 300 (fst ht_strings : Hashtbl.t string Adef.istr); 301 Hashtbl.clear (fst ht_strings); 302 303 if Mutil.verbose.val then do { 304 eprintf "\n"; 305 flush stderr 306 } 307 else (); 308}; 309 310value rebuild_fields2 db2 = do { 311 let fi_per = 312 {fi_nb = db2.Db2disk.patches.Db2disk.nb_per; 313 fi_ht = db2.Db2disk.patches.Db2disk.h_person; 314 fi_index_of_int = Adef.iper_of_int; fi_dir = "person"} 315 in 316 let fi_asc = 317 {fi_nb = db2.Db2disk.patches.Db2disk.nb_per; 318 fi_ht = db2.Db2disk.patches.Db2disk.h_ascend; 319 fi_index_of_int = Adef.iper_of_int; fi_dir = "person"} 320 in 321 let fi_uni = 322 {fi_nb = db2.Db2disk.patches.Db2disk.nb_per; 323 fi_ht = db2.Db2disk.patches.Db2disk.h_union; 324 fi_index_of_int = Adef.iper_of_int; fi_dir = "person"} 325 in 326 List.iter (rebuild_string_field db2 fi_per) 327 [("first_name", fun p -> p.Def.first_name); 328 ("surname", fun p -> p.Def.surname); 329 ("image", fun p -> p.Def.image); 330 ("public_name", fun p -> p.Def.public_name); 331 ("occupation", fun p -> p.Def.occupation); 332 ("birth_place", fun p -> p.Def.birth_place); 333 ("birth_src", fun p -> p.Def.birth_src); 334 ("baptism_place", fun p -> p.Def.baptism_place); 335 ("baptism_src", fun p -> p.Def.baptism_src); 336 ("death_place", fun p -> p.Def.death_place); 337 ("death_src", fun p -> p.Def.death_src); 338 ("burial_place", fun p -> p.Def.burial_place); 339 ("burial_src", fun p -> p.Def.burial_src); 340 ("notes", fun p -> p.Def.notes); 341 ("psources", fun p -> p.Def.psources)]; 342 rebuild_any_field_array db2 fi_per 0 True 343 ("occ", fun p -> p.Def.occ); 344 List.iter 345 (rebuild_list_with_string_field_array (fun f -> f) (fun f -> f) db2 346 fi_per) 347 [("qualifiers", fun p -> p.Def.qualifiers); 348 ("aliases", fun p -> p.Def.aliases); 349 ("first_names_aliases", fun p -> p.Def.first_names_aliases); 350 ("surnames_aliases", fun p -> p.Def.surnames_aliases)]; 351 rebuild_list_with_string_field_array Futil.map_title_strings 352 Futil.map_title_strings db2 fi_per 353 ("titles", fun p -> p.Def.titles); 354 rebuild_list_field_array db2 fi_per ("rparents", fun p -> p.Def.rparents); 355 rebuild_list2_field_array db2 fi_per ("related", fun p -> p.Def.related); 356 rebuild_any_field_array db2 fi_per Def.Neuter True 357 ("sex", fun p -> p.Def.sex); 358 rebuild_any_field_array db2 fi_per Def.IfTitles True 359 ("access", fun p -> p.Def.access); 360 List.iter (rebuild_any_field_array db2 fi_per Adef.codate_None True) 361 [("birth", fun p -> p.Def.birth); 362 ("baptism", fun p -> p.Def.baptism)]; 363 rebuild_any_field_array db2 fi_per Def.NotDead True 364 ("death", fun p -> p.Def.death); 365 rebuild_any_field_array db2 fi_per Def.UnknownBurial True 366 ("burial", fun p -> p.Def.burial); 367 rebuild_option_field_array db2 fi_asc (Adef.ifam_of_int (-1)) 368 ("parents", fun p -> p.Def.parents); 369 rebuild_any_field_array db2 fi_asc Adef.no_consang False 370 ("consang", fun p -> p.Def.consang); 371 rebuild_any_field_array db2 fi_uni [| |] False 372 ("family", fun p -> p.Def.family); 373 374 let fi_fam = 375 {fi_nb = db2.Db2disk.patches.Db2disk.nb_fam; 376 fi_ht = db2.Db2disk.patches.Db2disk.h_family; 377 fi_index_of_int = Adef.ifam_of_int; fi_dir = "family"} 378 in 379 let fi_cpl = 380 {fi_nb = db2.Db2disk.patches.Db2disk.nb_fam; 381 fi_ht = db2.Db2disk.patches.Db2disk.h_couple; 382 fi_index_of_int = Adef.ifam_of_int; fi_dir = "family"} 383 in 384 let fi_des = 385 {fi_nb = db2.Db2disk.patches.Db2disk.nb_fam; 386 fi_ht = db2.Db2disk.patches.Db2disk.h_descend; 387 fi_index_of_int = Adef.ifam_of_int; fi_dir = "family"} 388 in 389 rebuild_any_field_array db2 fi_fam Adef.codate_None True 390 ("marriage", fun f -> f.Def.marriage); 391 List.iter (rebuild_string_field db2 fi_fam) 392 [("marriage_place", fun f -> f.Def.marriage_place); 393 ("marriage_src", fun f -> f.Def.marriage_src); 394 ("comment", fun f -> f.Def.comment); 395 ("origin_file", fun f -> f.Def.origin_file); 396 ("fsources", fun f -> f.Def.fsources)]; 397 rebuild_any_field_array db2 fi_fam [| |] True 398 ("witnesses", fun f -> f.Def.witnesses); 399 rebuild_any_field_array db2 fi_fam Def.Married True 400 ("relation", fun f -> f.Def.relation); 401 rebuild_any_field_array db2 fi_fam Def.NotDivorced True 402 ("divorce", fun f -> f.Def.divorce); 403 List.iter (rebuild_any_field_array db2 fi_cpl (Adef.iper_of_int (-1)) True) 404 [("father", fun f -> Adef.father f); 405 ("mother", fun f -> Adef.mother f)]; 406 rebuild_any_field_array db2 fi_des [| |] False 407 ("children", fun f -> f.Def.children); 408 409 let nb_per = fi_per.fi_nb in 410 411 let new_d = Filename.concat db2.Db2disk.bdir2 "new_d" in 412 make_key_index db2 nb_per new_d; 413 Gc.compact (); 414 415 let particles = 416 Mutil.input_particles (Filename.concat db2.Db2disk.bdir2 "particles.txt") 417 in 418 Db2out.make_indexes new_d nb_per particles; 419 420 let old_d = Filename.concat db2.Db2disk.bdir2 "old_d" in 421 Mutil.remove_dir old_d; 422 Mutil.mkdir_p old_d; 423 List.iter 424 (fun f -> 425 Sys.rename (Filename.concat db2.Db2disk.bdir2 f) 426 (Filename.concat old_d f)) 427 ["family"; "person"; "person_of_key"; "person_of_name"; "patches"]; 428 List.iter 429 (fun f -> 430 Sys.rename (Filename.concat new_d f) 431 (Filename.concat db2.Db2disk.bdir2 f)) 432 ["family"; "person"; "person_of_key"; "person_of_name"]; 433}; 434 435value simple_output bname base carray = 436 match carray with 437 [ Some tab -> 438 Gwdb.apply_base2 base 439 (fun db2 -> do { 440 let bdir = db2.Db2disk.bdir2 in 441 let dir = 442 List.fold_left Filename.concat bdir ["person"; "consang"] 443 in 444 Mutil.mkdir_p dir; 445 let oc = open_out_bin (Filename.concat dir "data") in 446 output_value oc tab; 447 close_out oc; 448 let oc = open_out_bin (Filename.concat dir "access") in 449 let _ : int = 450 Iovalue.output_array_access oc (Array.get tab) (Array.length tab) 451 0 452 in 453 close_out oc; 454 let has_patches = 455 Sys.file_exists (Filename.concat bdir "patches") 456 in 457 if has_patches then do { 458 let list = 459 Hashtbl.fold 460 (fun ip a list -> 461 let a = 462 {(a) with Def.consang = tab.(Adef.int_of_iper ip)} 463 in 464 [(ip, a) :: list]) 465 db2.Db2disk.patches.Db2disk.h_ascend [] 466 in 467 List.iter 468 (fun (ip, a) -> 469 Hashtbl.replace db2.Db2disk.patches.Db2disk.h_ascend ip a) 470 list; 471 Db2disk.commit_patches2 db2; 472 rebuild_fields2 db2; 473 } 474 else (); 475 }) 476 | None -> 477 Gwdb.apply_base1 base 478 (fun base -> 479 let bname = base.Dbdisk.data.Dbdisk.bdir in 480 let no_patches = 481 not (Sys.file_exists (Filename.concat bname "patches")) 482 in 483 Outbase.gen_output (no_patches && not indexes.val) bname base) ] 484; 485 486value designation base p = 487 let first_name = Gwdb.p_first_name base p in 488 let nom = Gwdb.p_surname base p in 489 Mutil.iso_8859_1_of_utf_8 490 (first_name ^ "." ^ string_of_int (Gwdb.get_occ p) ^ " " ^ nom) 491; 492 493value main () = do { 494 Argl.parse speclist anonfun errmsg; 495 if fname.val = "" then do { 496 eprintf "Missing file name\n"; 497 eprintf "Use option -help for usage\n"; 498 flush stderr; 499 exit 2; 500 } 501 else (); 502 Secure.set_base_dir (Filename.dirname fname.val); 503 let f () = 504 let base = Gwdb.open_base fname.val in 505 try do { 506 Sys.catch_break True; 507 let carray = ConsangAll.compute base tlim.val scratch.val quiet.val in 508 simple_output fname.val base carray; 509 } 510 with 511 [ Consang.TopologicalSortError p -> do { 512 printf "\nError: loop in database, %s is his/her own ancestor.\n" 513 (designation base p); 514 flush stdout; 515 exit 2 516 } ] 517 in 518 lock (Mutil.lock_file fname.val) with 519 [ Accept -> f () 520 | Refuse -> do { 521 eprintf "Base is locked. Waiting... "; 522 flush stderr; 523 lock_wait (Mutil.lock_file fname.val) with 524 [ Accept -> do { eprintf "Ok\n"; flush stderr; f () } 525 | Refuse -> do { 526 printf "\nSorry. Impossible to lock base.\n"; 527 flush stdout; 528 exit 2 529 } ] 530 } ]; 531}; 532 533Printexc.catch main (); 534