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