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