1(* $Id: iolight.ml,v 5.13 2007-01-19 01:53:16 ddr Exp $ *)
2(* Copyright (c) 1998-2007 INRIA *)
3
4open Dbdisk;
5open Def;
6
7type person = dsk_person;
8type ascend = dsk_ascend;
9type union = dsk_union;
10type family = dsk_family;
11type couple = dsk_couple;
12type descend = dsk_descend;
13
14value magic_gwb = "GnWb0020";
15
16value check_magic =
17  let b = Bytes.create (String.length magic_gwb) in
18  fun ic ->
19    do {
20      really_input ic b 0 (String.length b);
21      if b <> magic_gwb then
22        if String.sub magic_gwb 0 4 = String.sub b 0 4 then
23          failwith "this is a GeneWeb base, but not compatible"
24        else
25          failwith "this is not a GeneWeb base, or it is a very old version"
26      else ()
27    }
28;
29
30type patches =
31  { p_person : ref (list (int * person));
32    p_ascend : ref (list (int * ascend));
33    p_union : ref (list (int * union));
34    p_family : ref (list (int * family));
35    p_couple : ref (list (int * couple));
36    p_descend : ref (list (int * descend));
37    p_string : ref (list (int * string));
38    p_name : ref (list (int * list iper)) }
39;
40
41value rec patch_len len =
42  fun
43  [ [] -> len
44  | [(i, _) :: l] -> patch_len (max len (i + 1)) l ]
45;
46
47value apply_patches tab plist plen =
48  if plist = [] then tab
49  else do {
50    let new_tab =
51      if plen > Array.length tab then do {
52        let new_tab = Array.make plen (Obj.magic 0) in
53        Array.blit tab 0 new_tab 0 (Array.length tab);
54        new_tab
55      }
56      else tab
57    in
58    List.iter (fun (i, v) -> new_tab.(i) := v) plist;
59    new_tab
60  }
61;
62
63value value_header_size = 20;
64value array_header_size len = if len < 8 then 1 else 5;
65
66(* to turn around lack of header in some output valued arrays version 4.10 *)
67value input_4_10_array ic pos len =
68  do {
69    Printf.eprintf "*** recovering 4.10 array...\n";
70    flush stderr;
71    seek_in ic (pos + value_header_size + array_header_size len);
72    Array.init len (fun _ -> Iovalue.input ic)
73  }
74;
75
76value make_record_access ic shift array_pos patches len name =
77  let tab = ref None in
78  let rec array () =
79    match tab.val with
80    [ Some x -> x
81    | None -> do {
82        Printf.eprintf "*** read %s\n" name;
83        flush stderr;
84        seek_in ic array_pos;
85        let v =
86          try input_value ic with
87          [ Failure _ -> input_4_10_array ic array_pos len ]
88        in
89        let t = apply_patches v patches.val r.len in
90        tab.val := Some t;
91        t
92      } ]
93  and r =
94    {load_array () = let _ = array () in (); get i = (array ()).(i);
95     set i v = (array ()).(i) := v; len = patch_len len patches.val;
96     output_array oc = Mutil.output_value_no_sharing oc (array () : array _);
97     clear_array () = tab.val := None}
98  in
99  r
100;
101
102value input_patches bname =
103  let patches =
104    match
105      try Some (open_in_bin (Filename.concat bname "patches")) with _ -> None
106    with
107    [ Some ic -> let p = input_value ic in do { close_in ic; p }
108    | None ->
109        {p_person = ref []; p_ascend = ref []; p_union = ref [];
110         p_family = ref []; p_couple = ref []; p_descend = ref [];
111         p_string = ref []; p_name = ref []} ]
112  in
113  patches
114;
115
116value input bname =
117  let bname =
118    if Filename.check_suffix bname ".gwb" then bname else bname ^ ".gwb"
119  in
120  let patches = input_patches bname in
121  let ic =
122    let ic = open_in_bin (Filename.concat bname "base") in
123    do { check_magic ic; ic }
124  in
125  let persons_len = input_binary_int ic in
126  let families_len = input_binary_int ic in
127  let strings_len = input_binary_int ic in
128  let persons_array_pos = input_binary_int ic in
129  let ascends_array_pos = input_binary_int ic in
130  let unions_array_pos = input_binary_int ic in
131  let families_array_pos = input_binary_int ic in
132  let couples_array_pos = input_binary_int ic in
133  let descends_array_pos = input_binary_int ic in
134  let strings_array_pos = input_binary_int ic in
135  let norigin_file = input_value ic in
136  let shift = 0 in
137  let persons =
138    make_record_access ic shift persons_array_pos patches.p_person persons_len
139      "persons"
140  in
141  let shift = shift + persons_len * Iovalue.sizeof_long in
142  let ascends =
143    make_record_access ic shift ascends_array_pos patches.p_ascend persons_len
144      "ascends"
145  in
146  let shift = shift + persons_len * Iovalue.sizeof_long in
147  let unions =
148    make_record_access ic shift unions_array_pos patches.p_union persons_len
149      "unions"
150  in
151  let shift = shift + persons_len * Iovalue.sizeof_long in
152  let families =
153    make_record_access ic shift families_array_pos patches.p_family
154      families_len "families"
155  in
156  let shift = shift + families_len * Iovalue.sizeof_long in
157  let couples =
158    make_record_access ic shift couples_array_pos patches.p_couple families_len
159      "couples"
160  in
161  let shift = shift + families_len * Iovalue.sizeof_long in
162  let descends =
163    make_record_access ic shift descends_array_pos patches.p_descend
164      families_len "descends"
165  in
166  let shift = shift + families_len * Iovalue.sizeof_long in
167  let strings =
168    make_record_access ic shift strings_array_pos patches.p_string strings_len
169      "strings"
170  in
171  let cleanup () = close_in ic in
172  let read_notes fnotes rn_mode =
173    let fname =
174      if fnotes = "" then "notes"
175      else Filename.concat "notes_d" (fnotes ^ ".txt")
176    in
177    match
178      try Some (Secure.open_in (Filename.concat bname fname)) with
179      [ Sys_error _ -> None ]
180    with
181    [ Some ic -> do {
182        let str =
183          match rn_mode with
184          [ RnDeg -> if in_channel_length ic = 0 then "" else " "
185          | Rn1Ln -> try input_line ic with [ End_of_file -> "" ]
186          | RnAll ->
187              loop 0 where rec loop len =
188                match
189                  try Some (input_char ic) with [ End_of_file -> None ]
190                with
191                [ Some c -> loop (Buff.store len c)
192                | _ -> Buff.get len ] ]
193        in
194        close_in ic;
195        str
196      }
197    | None -> "" ]
198  in
199  let commit_notes fnotes s =
200    let fname =
201      if fnotes = "" then "notes"
202      else do {
203        try Unix.mkdir (Filename.concat bname "notes_d") 0o755 with _ -> ();
204        Filename.concat "notes_d" (fnotes ^ ".txt")
205      }
206    in
207    let fname = Filename.concat bname fname in
208    do {
209      try Sys.remove (fname ^ "~") with [ Sys_error _ -> () ];
210      try Sys.rename fname (fname ^ "~") with _ -> ();
211      if s = "" then ()
212      else do {
213        let oc = open_out fname in output_string oc s; close_out oc;
214      }
215    }
216  in
217  let bnotes =
218    {nread = read_notes; norigin_file = norigin_file; efiles _ = []}
219  in
220  let base_data =
221    {persons = persons; ascends = ascends; unions = unions;
222     visible = { v_write = fun []; v_get = fun [] };
223     families = families; couples = couples; descends = descends;
224     strings = strings; particles = []; bnotes = bnotes; bdir = bname}
225  in
226  let base_func =
227    {person_of_key = fun []; persons_of_name = fun [];
228     strings_of_fsname = fun [];
229     persons_of_surname = {find = fun []; cursor = fun []; next = fun []};
230     persons_of_first_name = {find = fun []; cursor = fun []; next = fun []};
231     patch_person = fun []; patch_ascend = fun [];
232     patch_union = fun []; patch_family = fun []; patch_couple = fun [];
233     patch_descend = fun []; patch_name = fun []; insert_string = fun [];
234     commit_patches = fun []; commit_notes = commit_notes;
235     patched_ascends = fun []; is_patched_person _ = False;
236     cleanup = cleanup}
237  in
238  {data = base_data; func = base_func}
239;
240