diff --git a/.gitignore b/.gitignore index dede862f22..ba73b537f0 100644 --- a/.gitignore +++ b/.gitignore @@ -19,8 +19,7 @@ geneweb.install # Generated from .camlp5 sources bin/distrib/setup/setup.ml -bin/distrib/ged2gwb/ged2gwb.ml -bin/distrib/ged2gwb/ged2gwb2.ml +bin/distrib/ged2gwb/ged2gwb1.ml lib/api_saisie_piqi.ml lib/api_saisie_piqi_ext.ml lib/gwlib.ml diff --git a/Makefile b/Makefile index fe4bced873..e11c2c1abc 100644 --- a/Makefile +++ b/Makefile @@ -15,25 +15,22 @@ DISTRIB_DIR=distribution BUILD_DIR=_build/default EXE = \ - bin/distrib/connex.exe \ - bin/distrib/ged2gwb.exe \ - bin/distrib/ged2gwb2.exe \ - bin/distrib/gwb2ged.exe \ - bin/distrib/gwc1.exe \ - bin/distrib/gwc2.exe \ - bin/distrib/gwd.exe \ - bin/distrib/gwdiff.exe \ - bin/distrib/gwtp.exe \ - bin/distrib/gwu.exe \ - bin/distrib/mk_consang.exe \ - bin/distrib/setup.exe \ - bin/distrib/update_nldb.exe \ + bin/distrib/connex \ + bin/distrib/consang \ + bin/distrib/ged2gwb \ + bin/distrib/gwb2ged \ + bin/distrib/gwc \ + bin/distrib/gwd \ + bin/distrib/gwdiff \ + bin/distrib/gwtp \ + bin/distrib/gwu \ + bin/distrib/setup \ + bin/distrib/update_nldb \ ###### [BEGIN] Generated files section CAMLP5_PA_EXTEND_FILES = \ - bin/distrib/ged2gwb/ged2gwb \ - bin/distrib/ged2gwb/ged2gwb2 \ + bin/distrib/ged2gwb/ged2gwb1 \ lib/templ \ lib/update \ bin/distrib/setup/setup @@ -66,7 +63,7 @@ lib/gwlib.ml: echo " try Sys.getenv \"GWPREFIX\"" >> $@ echo " with Not_found -> \"$(PREFIX)\"" | sed -e 's|\\|/|g' >> $@ -CPPO_D=$(API_D) +CPPO_D=$(API_D) $(GWDB_D) %/dune: %/dune.in cat $< \ @@ -75,6 +72,7 @@ CPPO_D=$(API_D) -e "s/%%%CPPO_D%%%/$(CPPO_D)/g" \ -e "s/%%%API_PKG%%%/$(API_PKG)/g" \ -e "s/%%%SOSA_PKG%%%/$(SOSA_PKG)/g" \ + -e "s/%%%GWDB_PKG%%%/$(GWDB_PKG)/g" \ > $@ hd/etc/version.txt: @@ -154,15 +152,11 @@ distrib: exe cp etc/a.gwf $(DISTRIB_DIR)/gw/. echo "127.0.0.1" > $(DISTRIB_DIR)/gw/only.txt echo "-setup_link" > $(DISTRIB_DIR)/gw/gwd.arg - cp $(BUILD_DISTRIB_DIR)gwc1.exe $(DISTRIB_DIR)/gw/gwc$(EXT); - cp $(BUILD_DISTRIB_DIR)gwc1.exe $(DISTRIB_DIR)/gw/gwc1$(EXT); - cp $(BUILD_DISTRIB_DIR)gwc2.exe $(DISTRIB_DIR)/gw/gwc2$(EXT); - cp $(BUILD_DISTRIB_DIR)mk_consang.exe $(DISTRIB_DIR)/gw/consang$(EXT); - cp $(BUILD_DISTRIB_DIR)mk_consang.exe $(DISTRIB_DIR)/gw/mk_consang$(EXT); + cp $(BUILD_DISTRIB_DIR)gwc.exe $(DISTRIB_DIR)/gw/gwc$(EXT); + cp $(BUILD_DISTRIB_DIR)consang.exe $(DISTRIB_DIR)/gw/consang$(EXT); cp $(BUILD_DISTRIB_DIR)gwd.exe $(DISTRIB_DIR)/gw/gwd$(EXT); cp $(BUILD_DISTRIB_DIR)gwu.exe $(DISTRIB_DIR)/gw/gwu$(EXT); cp $(BUILD_DISTRIB_DIR)ged2gwb.exe $(DISTRIB_DIR)/gw/ged2gwb$(EXT); - cp $(BUILD_DISTRIB_DIR)ged2gwb2.exe $(DISTRIB_DIR)/gw/ged2gwb2$(EXT); cp $(BUILD_DISTRIB_DIR)gwb2ged.exe $(DISTRIB_DIR)/gw/gwb2ged$(EXT); cp $(BUILD_DISTRIB_DIR)connex.exe $(DISTRIB_DIR)/gw/connex$(EXT); cp $(BUILD_DISTRIB_DIR)gwdiff.exe $(DISTRIB_DIR)/gw/gwdiff$(EXT); diff --git a/benchmark/bench.ml b/benchmark/bench.ml index 08f2d94310..a5627ca526 100644 --- a/benchmark/bench.ml +++ b/benchmark/bench.ml @@ -1,5 +1,3 @@ -open Geneweb - let bench name n fn arg = ignore @@ Benchmark.latency1 ~name n (List.map fn) arg diff --git a/benchmark/dune.in b/benchmark/dune.in index a1a5aac967..5367c28874 100644 --- a/benchmark/dune.in +++ b/benchmark/dune.in @@ -1,6 +1,6 @@ (executable (name bench) - (libraries unix geneweb.wserver %%%SOSA_PKG%%% geneweb benchmark) + (libraries unix geneweb.wserver %%%SOSA_PKG%%% %%%GWDB_PKG%%% geneweb benchmark) ) (alias (name runbench) (action (run ./bench.exe) ) ) diff --git a/bin/distrib/db1link/db1link.ml b/bin/distrib/db1link/db1link.ml index db2a10d13e..0bc1c6723c 100644 --- a/bin/distrib/db1link/db1link.ml +++ b/bin/distrib/db1link/db1link.ml @@ -1,5 +1,6 @@ (* Copyright (c) 1998-2007 INRIA *) +open Geneweb open Gwcomp open Dbdisk open Def @@ -1346,10 +1347,10 @@ let link next_family_fun bdir = linked_base gen per_index_ic per_ic fam_index_ic fam_ic bdir in Hashtbl.clear gen.g_patch_p; - let base = Gwdb.base_of_base1 dsk_base in + let base = dsk_base in if !do_check && gen.g_pcnt > 0 then begin let changed_p (ip, p, o_sex, o_rpar) = - let p = Gwdb.dsk_person_of_person p in + let p = Gwdb1.dsk_person_of_person (Gwdb1.OfGwdb.person p) in let p = {p with sex = fold_option (fun s -> s) p.sex o_sex; rparents = @@ -1361,6 +1362,7 @@ let link next_family_fun bdir = in let i = Adef.int_of_iper ip in Hashtbl.replace gen.g_patch_p i p in + let base = Gwdb1.ToGwdb.base base in Check.check_base base (set_error base gen) (set_warning base) (fun i -> gen.g_def.(i)) changed_p !pr_stats; flush stdout @@ -1368,7 +1370,7 @@ let link next_family_fun bdir = if not gen.g_errored then begin if !do_consang then - (let _ = (ConsangAll.compute base (-1) true : _ option) in ()); + (let _ = (ConsangAll.compute (Gwdb1.ToGwdb.base base) (-1) true : _ option) in ()); Gc.compact (); Outbase.output bdir dsk_base; output_wizard_notes bdir gen.g_wiznotes; @@ -1376,7 +1378,7 @@ let link next_family_fun bdir = (try Mutil.remove_dir tmp_dir with _ -> ()); (try Unix.rmdir "gw_tmp" with _ -> ()); output_command_line bdir; - Util.init_cache_info bdir base; + Util.init_cache_info bdir (Gwdb1.ToGwdb.base base); true end else false diff --git a/bin/distrib/db1link/db1link.mli b/bin/distrib/db1link/db1link.mli index a7f576f87f..236c694232 100644 --- a/bin/distrib/db1link/db1link.mli +++ b/bin/distrib/db1link/db1link.mli @@ -1,6 +1,8 @@ (* $Id: db1link.mli,v 5.2 2008-01-15 11:06:04 ddr Exp $ *) (* Copyright (c) 2007-2008 INRIA *) +open Geneweb + type file_info = { mutable f_curr_src_file : string; mutable f_curr_gwo_file : string; diff --git a/bin/distrib/db2link/db2link.ml b/bin/distrib/db2link/db2link.ml index 6190ad5a87..2b0bf99036 100644 --- a/bin/distrib/db2link/db2link.ml +++ b/bin/distrib/db2link/db2link.ml @@ -1,6 +1,7 @@ (* $Id: db2link.ml,v 5.18 2012-01-27 08:53:53 ddr Exp $ *) (* Copyright (c) 2006-2008 INRIA *) +open Geneweb open Def open Gwcomp @@ -1175,7 +1176,7 @@ let fold_option fsome vnone = | None -> vnone let changed_p (ip, p, o_sex, o_rpar) = - let p = Gwdb.dsk_person_of_person p in + let p = Gwdb2.dsk_person_of_person (Gwdb2.OfGwdb.person p) in let _p = {p with sex = fold_option (fun s -> s) p.sex o_sex; rparents = diff --git a/bin/distrib/dune.in b/bin/distrib/dune.in index 42b9e651d0..c4ba695e7e 100644 --- a/bin/distrib/dune.in +++ b/bin/distrib/dune.in @@ -1,25 +1,40 @@ +(env (dev (flags (-w -33) ) ) ) + (include_subdirs unqualified) (executables - (public_names connex gwc1 gwc2 gwd gwu mk_consang setup update_nldb) - (modules connex gwc1 gwc2 gwd gwu mk_consang setup update_nldb) - (libraries %%%SOSA_PKG%%% geneweb geneweb.wserver) + (public_names connex gwb2ged gwd gwdiff gwu setup update_nldb) + (modules connex gwb2ged gwdiff gwd gwu setup update_nldb) + (libraries str %%%GWDB_PKG%%% geneweb geneweb.wserver) ) (executables - (public_names ged2gwb ged2gwb2) - (modules ged2gwb ged2gwb2 utf8List) - (libraries unix str camlp5.gramlib %%%SOSA_PKG%%% geneweb) + (names gwtp) + (modules gwtp httpEnv iolight) + (libraries %%%GWDB_PKG%%% geneweb) ) -(executables - (public_names gwb2ged gwdiff) - (modules gwb2ged gwdiff) - (libraries str %%%SOSA_PKG%%% geneweb) +(rule (copy mk_consang/mk_consang.ml consang.ml)) +(executable + (public_name consang) + (modules consang) + (preprocess (action (run %{bin:cppo} %%%CPPO_D%%% %{input-file}))) + (libraries %%%GWDB_PKG%%% geneweb) ) -(executables - (public_names gwtp) - (modules gwtp httpEnv iolight) - (libraries %%%SOSA_PKG%%% geneweb) +#ifdef GWDB1 +(library (name db1link) (wrapped false) (libraries geneweb.gwdb1 geneweb) (modules db1link)) +(rule (copy gwc/gwc1.ml gwc.ml)) +(rule (copy ged2gwb/ged2gwb1.ml ged2gwb.ml)) +(executable + (public_name gwc) + (modules gwc) + (preprocess (action (run %{bin:cppo} %%%CPPO_D%%% %{input-file}))) + (libraries geneweb.gwdb1 geneweb geneweb.wserver db1link) +) +(executable + (public_name ged2gwb) + (modules ged2gwb utf8List) + (libraries unix str camlp5.gramlib geneweb.gwdb1 geneweb) ) +#endif diff --git a/bin/distrib/ged2gwb/ged2gwb1.camlp5.ml b/bin/distrib/ged2gwb/ged2gwb1.camlp5.ml index 1c70f10860..33aee677f9 100644 --- a/bin/distrib/ged2gwb/ged2gwb1.camlp5.ml +++ b/bin/distrib/ged2gwb/ged2gwb1.camlp5.ml @@ -3605,8 +3605,9 @@ let finish_base base (persons, families, _, _) = check_parents_sex base persons families; check_parents_children base ascends unions couples descends; if !try_negative_dates then negative_dates base persons families; - let base = Gwdb.base_of_base1 base in + let base = base in if !do_check then + let base = Gwdb1.ToGwdb.base base in Check.check_base base (fun x -> Check.print_base_error !log_oc base x; Printf.fprintf !log_oc "\n") (function diff --git a/bin/distrib/ged2gwb/ged2gwb2.camlp5.ml b/bin/distrib/ged2gwb/ged2gwb2.camlp5.ml deleted file mode 100644 index aa7665594e..0000000000 --- a/bin/distrib/ged2gwb/ged2gwb2.camlp5.ml +++ /dev/null @@ -1,3260 +0,0 @@ -(* Copyright (c) 1998-2008 INRIA *) - -open Geneweb -open Def -open Mutil - -type person = (iper, Adef.istr) gen_person -type ascend = ifam gen_ascend -type union = ifam gen_union -type family = (iper, Adef.istr) gen_family -type couple = iper gen_couple -type descend = iper gen_descend - -let get_first_name p = p.Def.first_name -let get_key_index p = p.Def.key_index -let get_notes p = p.Def.notes -let get_occ p = p.Def.occ -let get_related p = p.Def.related -let get_rparents p = p.Def.rparents -let get_sex p = p.Def.sex -let get_surname p = p.Def.surname -let person_with_related p r = {p with related = r} -let person_with_rparents p r = {p with rparents = r} -let person_with_sex p s = {p with sex = s} -let person_of_gen_person p = p -let gen_person_of_person p = p - -let get_parents a = a.Def.parents - -let ascend_with_parents a p = {parents = p; consang = a.consang} -let ascend_of_gen_ascend a = a - -let get_family u = u.Def.family - -let union_of_gen_union u = u - -let get_witnesses f = f.Def.witnesses - -let family_of_gen_family f = f -let gen_family_of_family f = f - -let get_father c = Adef.father c -let couple_of_gen_couple c = c - -let descend_of_gen_descend d = d - -let couple _ x y = Adef.couple x y - -let log_oc = ref stdout - -type record = - { rlab : string; - rval : string; - rcont : string; - rsons : record list; - rpos : int; - mutable rused : bool } - -type ('a, 'b, 'c, 'd) choice3 = - Left3 of 'a - | Right3 of 'b * 'c * 'd -type month_number_dates = - MonthDayDates - | DayMonthDates - | NoMonthNumberDates - | MonthNumberHappened of string - -type charset = Ansel | Ansi | Ascii | Msdos | MacIntosh | Utf8 - -type case = NoCase | LowerCase | UpperCase - -let lowercase_first_names = ref false -let case_surnames = ref NoCase -let extract_first_names = ref false -let extract_public_names = ref true -let charset_option = ref None -let charset = ref Ascii -let alive_years = ref 80 -let dead_years = ref 120 -let try_negative_dates = ref false -let no_negative_dates = ref false -let month_number_dates = ref NoMonthNumberDates -let no_public_if_titles = ref false -let first_names_brackets = ref None -let untreated_in_notes = ref false -let force = ref false -let default_source = ref "" -let default_name = ref "?" -let relation_status = ref Married -let no_picture = ref false - -(* Reading input *) - -let line_cnt = ref 1 -let in_file = ref "" - -let print_location pos = - Printf.fprintf !log_oc "File \"%s\", line %d:\n" !in_file pos - -let rec skip_eol = - parser - | [< ''\010' | '\013'; _ = skip_eol >] -> () - | [< >] -> () - -let rec get_to_eoln len = - parser - | [< ''\010' | '\013'; _ = skip_eol >] -> Buff.get len - | [< ''\t'; s >] -> get_to_eoln (Buff.store len ' ') s - | [< 'c; s >] -> get_to_eoln (Buff.store len c) s - | [< >] -> Buff.get len - -let rec skip_to_eoln = - parser - | [< ''\010' | '\013'; _ = skip_eol >] -> () - | [< '_; s >] -> skip_to_eoln s - | [< >] -> () - -let eol_chars = ['\010'; '\013'] -let rec get_ident len = - parser - | [< '' ' | '\t' >] -> Buff.get len - | [< 'c when not (List.mem c eol_chars); s >] -> - get_ident (Buff.store len c) s - | [< >] -> Buff.get len - -let skip_space = - parser - | [< '' ' | '\t' >] -> () - | [< >] -> () - -let rec line_start num = - parser - | [< '' '; s >] -> line_start num s - | [< 'x when x = num >] -> () - -let ascii_of_msdos s = - let conv_char i = - let cc = - match Char.code s.[i] with - 0o200 -> 0o307 - | 0o201 -> 0o374 - | 0o202 -> 0o351 - | 0o203 -> 0o342 - | 0o204 -> 0o344 - | 0o205 -> 0o340 - | 0o206 -> 0o345 - | 0o207 -> 0o347 - | 0o210 -> 0o352 - | 0o211 -> 0o353 - | 0o212 -> 0o350 - | 0o213 -> 0o357 - | 0o214 -> 0o356 - | 0o215 -> 0o354 - | 0o216 -> 0o304 - | 0o217 -> 0o305 - | 0o220 -> 0o311 - | 0o221 -> 0o346 - | 0o222 -> 0o306 - | 0o223 -> 0o364 - | 0o224 -> 0o366 - | 0o225 -> 0o362 - | 0o226 -> 0o373 - | 0o227 -> 0o371 - | 0o230 -> 0o377 - | 0o231 -> 0o326 - | 0o232 -> 0o334 - | 0o233 -> 0o242 - | 0o234 -> 0o243 - | 0o235 -> 0o245 - | 0o240 -> 0o341 - | 0o241 -> 0o355 - | 0o242 -> 0o363 - | 0o243 -> 0o372 - | 0o244 -> 0o361 - | 0o245 -> 0o321 - | 0o246 -> 0o252 - | 0o247 -> 0o272 - | 0o250 -> 0o277 - | 0o252 -> 0o254 - | 0o253 -> 0o275 - | 0o254 -> 0o274 - | 0o255 -> 0o241 - | 0o256 -> 0o253 - | 0o257 -> 0o273 - | 0o346 -> 0o265 - | 0o361 -> 0o261 - | 0o366 -> 0o367 - | 0o370 -> 0o260 - | 0o372 -> 0o267 - | 0o375 -> 0o262 - | c -> c - in - Char.chr cc - in - String.init (String.length s) conv_char - -let ascii_of_macintosh s = - let conv_char i = - let cc = - match Char.code s.[i] with - 0o200 -> 0o304 - | 0o201 -> 0o305 - | 0o202 -> 0o307 - | 0o203 -> 0o311 - | 0o204 -> 0o321 - | 0o205 -> 0o326 - | 0o206 -> 0o334 - | 0o207 -> 0o341 - | 0o210 -> 0o340 - | 0o211 -> 0o342 - | 0o212 -> 0o344 - | 0o213 -> 0o343 - | 0o214 -> 0o345 - | 0o215 -> 0o347 - | 0o216 -> 0o351 - | 0o217 -> 0o350 - | 0o220 -> 0o352 - | 0o221 -> 0o353 - | 0o222 -> 0o355 - | 0o223 -> 0o354 - | 0o224 -> 0o356 - | 0o225 -> 0o357 - | 0o226 -> 0o361 - | 0o227 -> 0o363 - | 0o230 -> 0o362 - | 0o231 -> 0o364 - | 0o232 -> 0o366 - | 0o233 -> 0o365 - | 0o234 -> 0o372 - | 0o235 -> 0o371 - | 0o236 -> 0o373 - | 0o237 -> 0o374 - | 0o241 -> 0o260 - | 0o244 -> 0o247 - | 0o245 -> 0o267 - | 0o246 -> 0o266 - | 0o247 -> 0o337 - | 0o250 -> 0o256 - | 0o256 -> 0o306 - | 0o257 -> 0o330 - | 0o264 -> 0o245 - | 0o273 -> 0o252 - | 0o274 -> 0o272 - | 0o276 -> 0o346 - | 0o277 -> 0o370 - | 0o300 -> 0o277 - | 0o301 -> 0o241 - | 0o302 -> 0o254 - | 0o307 -> 0o253 - | 0o310 -> 0o273 - | 0o312 -> 0o040 - | 0o313 -> 0o300 - | 0o314 -> 0o303 - | 0o315 -> 0o325 - | 0o320 -> 0o255 - | 0o326 -> 0o367 - | 0o330 -> 0o377 - | 0o345 -> 0o302 - | 0o346 -> 0o312 - | 0o347 -> 0o301 - | 0o350 -> 0o313 - | 0o351 -> 0o310 - | 0o352 -> 0o315 - | 0o353 -> 0o316 - | 0o354 -> 0o317 - | 0o355 -> 0o314 - | 0o356 -> 0o323 - | 0o357 -> 0o324 - | 0o361 -> 0o322 - | 0o362 -> 0o332 - | 0o363 -> 0o333 - | 0o364 -> 0o331 - | c -> c - in - Char.chr cc - in - String.init (String.length s) conv_char - -let utf8_of_string s = - match !charset with - Ansel -> utf_8_of_iso_8859_1 (Ansel.to_iso_8859_1 s) - | Ansi -> Mutil.utf_8_of_iso_8859_1 s - | Ascii -> Mutil.utf_8_of_iso_8859_1 s - | Msdos -> Mutil.utf_8_of_iso_8859_1 (ascii_of_msdos s) - | MacIntosh -> Mutil.utf_8_of_iso_8859_1 (ascii_of_macintosh s) - | Utf8 -> s - -let rec get_lev n = - parser - [< _ = line_start n; _ = skip_space; r1 = get_ident 0; strm >] -> - let (rlab, rval, rcont, l) = - if String.length r1 > 0 && r1.[0] = '@' then parse_address n r1 strm - else parse_text n r1 strm - in - {rlab = rlab; rval = utf8_of_string rval; - rcont = utf8_of_string rcont; rsons = List.rev l; rpos = !line_cnt; - rused = false} -and parse_address n r1 = - parser - [< r2 = get_ident 0; r3 = get_to_eoln 0 (* ? "get to eoln" *); - l = get_lev_list [] (Char.chr (Char.code n + 1)) (* ? "get lev list" *) >] -> - (r2, r1, r3, l) -and parse_text n r1 = - parser - [< r2 = get_to_eoln 0; - l = get_lev_list [] (Char.chr (Char.code n + 1)) (* ? "get lev list" *) >] -> - (r1, r2, "", l) -and get_lev_list l n = - parser - | [< x = get_lev n; s >] -> get_lev_list (x :: l) n s - | [< >] -> l - -(* Error *) - -let bad_dates_warned = ref false - -let print_bad_date pos d = - if !bad_dates_warned then () - else - begin - bad_dates_warned := true; - print_location pos; - Printf.fprintf !log_oc "Can't decode date %s\n" d; - flush !log_oc - end - -let check_month m = - if m < 1 || m > 12 then - begin - Printf.fprintf !log_oc "Bad (numbered) month in date: %d\n" m; - flush !log_oc - end - -let warning_month_number_dates () = - match !month_number_dates with - MonthNumberHappened s -> - Printf.fprintf !log_oc - " Warning: the file holds dates with numbered months \ - (like: 12/05/1912).\n\n \ - GEDCOM standard *requires* that months in dates be identifiers. The \ - correct form for this example would be 12 MAY 1912 or 5 DEC \ - 1912.\n\n \ - Consider restarting with option \"-dates_dm\" or \"-dates_md\".\n \ - Use option -help to see what they do.\n\n\ \ - (example found in gedcom: \"%s\")" - s; - flush !log_oc - | _ -> () - -(* Decoding fields *) - -let rec skip_spaces = - parser - | [< '' '; s >] -> skip_spaces s - | [< >] -> () - -let rec ident_slash len = - parser - | [< ''/' >] -> Buff.get len - | [< ''\t'; a = ident_slash (Buff.store len ' ') >] -> a - | [< 'c; a = ident_slash (Buff.store len c) >] -> a - | [< >] -> Buff.get len - -let strip c str = - let start = - let rec loop i = - if i = String.length str then i - else if str.[i] = c then loop (i + 1) - else i - in - loop 0 - in - let stop = - let rec loop i = - if i = -1 then i + 1 else if str.[i] = c then loop (i - 1) else i + 1 - in - loop (String.length str - 1) - in - if start = 0 && stop = String.length str then str - else if start >= stop then "" - else String.sub str start (stop - start) - -let strip_spaces = strip ' ' -let strip_newlines = strip '\n' - -let parse_name = - parser - [< _ = skip_spaces; - invert = - ( parser - | [< ''/' >] -> true - | [< >] -> false ) ; - f = ident_slash 0; _ = skip_spaces; s = ident_slash 0 >] -> - let (f, s) = if invert then (s, f) else (f, s) in - let f = strip_spaces f in - let s = strip_spaces s in - ((if f = "" then "x" else f), (if s = "" then "?" else s)) - -let rec find_field lab = - function - r :: rl -> - if r.rlab = lab then begin r.rused <- true; Some r end - else find_field lab rl - | [] -> None - -let rec find_all_fields lab = - function - r :: rl -> - if r.rlab = lab then - begin r.rused <- true; r :: find_all_fields lab rl end - else find_all_fields lab rl - | [] -> [] - -let rec find_field_with_value lab v = - function - r :: rl -> - if r.rlab = lab && r.rval = v then begin r.rused <- true; true end - else find_field_with_value lab v rl - | [] -> false - -let rec lexing_date = - parser - | [< ''0'..'9' as c; n = number (Buff.store 0 c) >] -> ("INT", n) - | [< ''A'..'Z' as c; i = ident (Buff.store 0 c) >] -> ("ID", i) - | [< ''('; len = text 0 >] -> ("TEXT", Buff.get len) - | [< ''.' >] -> ("", ".") - | [< '' ' | '\t' | '\013'; s >] -> lexing_date s - | [< _ = Stream.empty >] -> ("EOI", "") - | [< 'x >] -> ("", String.make 1 x) -and number len = - parser - | [< ''0'..'9' as c; a = number (Buff.store len c) >] -> a - | [< >] -> Buff.get len -and ident len = - parser - | [< ''A'..'Z' as c; a = ident (Buff.store len c) >] -> a - | [< >] -> Buff.get len -and text len = - parser - | [< '')' >] -> len - | [< ''('; len = text (Buff.store len '('); s >] -> - text (Buff.store len ')') s - | [< 'c; s >] -> text (Buff.store len c) s - | [< >] -> len - -let make_date_lexing s = Stream.from (fun _ -> Some (lexing_date s)) - -let tparse = Token.default_match - -let using_token (p_con, _) = - match p_con with - "" | "INT" | "ID" | "TEXT" | "EOI" -> () - | _ -> - raise - (Token.Error - ("the constructor \"" ^ p_con ^ - "\" is not recognized by the lexer")) - -let date_lexer = - {Token.tok_func = (fun s -> make_date_lexing s, (fun _ -> Token.dummy_loc)); - Token.tok_using = using_token; Token.tok_removing = (fun _ -> ()); - Token.tok_match = tparse; Token.tok_text = (fun _ -> ""); - Token.tok_comm = None} - -type 'a range = - Begin of 'a - | End of 'a - | BeginEnd of 'a * 'a - -let date_g = Grammar.gcreate date_lexer -let date_value = Grammar.Entry.create date_g "date value" -let date_interval = Grammar.Entry.create date_g "date interval" -let date_value_recover = Grammar.Entry.create date_g "date value" - -let is_roman_int x = - try let _ = Mutil.arabian_of_roman x in true with Not_found -> false - -let start_with_int x = - try let s = String.sub x 0 1 in let _ = int_of_string s in true with - _ -> false - -let roman_int = - let p = - parser [< '("ID", x) when is_roman_int x >] -> Mutil.arabian_of_roman x - in - Grammar.Entry.of_parser date_g "roman int" p - -let date_str = ref "" -let make_date n1 n2 n3 = - let n3 = - if !no_negative_dates then - match n3 with - Some n3 -> Some (abs n3) - | None -> None - else n3 - in - match n1, n2, n3 with - Some d, Some m, Some y -> - let (d, m) = - match m with - Right m -> d, m - | Left m -> - match !month_number_dates with - DayMonthDates -> check_month m; d, m - | MonthDayDates -> check_month d; m, d - | _ -> - if d >= 1 && m >= 1 && d <= 31 && m <= 31 then - if d > 13 && m <= 13 then d, m - else if m > 13 && d <= 13 then m, d - else if d > 13 && m > 13 then 0, 0 - else - begin - month_number_dates := MonthNumberHappened !date_str; - 0, 0 - end - else 0, 0 - in - let (d, m) = if m < 1 || m > 13 then 0, 0 else d, m in - {day = d; month = m; year = y; prec = Sure; delta = 0} - | None, Some m, Some y -> - let m = - match m with - Right m -> m - | Left m -> m - in - {day = 0; month = m; year = y; prec = Sure; delta = 0} - | None, None, Some y -> - {day = 0; month = 0; year = y; prec = Sure; delta = 0} - | Some y, None, None -> - {day = 0; month = 0; year = y; prec = Sure; delta = 0} - | _ -> raise (Stream.Error "bad date") - -let recover_date cal = - function - Dgreg (d, Dgregorian) -> - let d = - match cal with - Dgregorian -> d - | Djulian -> Calendar.gregorian_of_julian d - | Dfrench -> Calendar.gregorian_of_french d - | Dhebrew -> Calendar.gregorian_of_hebrew d - in - Dgreg (d, cal) - | d -> d - -(* [@@@ocaml.warning "-27"] *) -EXTEND - GLOBAL: date_value date_interval date_value_recover; - date_value: - [ [ d = date_or_text; EOI -> d ] ] - ; - date_value_recover: - [ [ "@"; "#"; ID "DGREGORIAN"; "@"; d = date_value -> - recover_date Dgregorian d - | "@"; "#"; ID "DJULIAN"; "@"; d = date_value -> - recover_date Djulian d - | "@"; "#"; ID "DFRENCH"; ID "R"; "@"; d = date_value -> - recover_date Dfrench d - | "@"; "#"; ID "DHEBREW"; "@"; d = date_value -> - recover_date Dhebrew d ] ] - ; - date_interval: - [ [ ID "BEF"; dt = date_or_text; EOI -> End dt - | ID "AFT"; dt = date_or_text; EOI -> Begin dt - | ID "BET"; dt = date_or_text; ID "AND"; dt1 = date_or_text; EOI -> - BeginEnd (dt, dt1) - | ID "TO"; dt = date_or_text; EOI -> End dt - | ID "FROM"; dt = date_or_text; EOI -> Begin dt - | ID "FROM"; dt = date_or_text; ID "TO"; dt1 = date_or_text; EOI -> - BeginEnd (dt, dt1) - | dt = date_or_text; EOI -> Begin dt ] ] - ; - date_or_text: - [ [ dr = date_range -> - begin match dr with - | Begin (d, cal) -> Dgreg ({d with prec = After}, cal) - | End (d, cal) -> Dgreg ({d with prec = Before}, cal) - | BeginEnd ((d1, cal1), (d2, cal2)) -> - let dmy2 = - match cal2 with - | Dgregorian -> - {day2 = d2.day; month2 = d2.month; - year2 = d2.year; delta2 = 0} - | Djulian -> - let dmy2 = Calendar.julian_of_gregorian d2 in - {day2 = dmy2.day; month2 = dmy2.month; - year2 = dmy2.year; delta2 = 0} - | Dfrench -> - let dmy2 = Calendar.french_of_gregorian d2 in - {day2 = dmy2.day; month2 = dmy2.month; - year2 = dmy2.year; delta2 = 0} - | Dhebrew -> - let dmy2 = Calendar.hebrew_of_gregorian d2 in - {day2 = dmy2.day; month2 = dmy2.month; - year2 = dmy2.year; delta2 = 0} - in - Dgreg ({d1 with prec = YearInt dmy2}, cal1) end - | (d, cal) = date -> Dgreg (d, cal) - | s = TEXT -> Dtext s ] ] - ; - date_range: - [ [ ID "BEF"; dt = date -> End dt - | ID "AFT"; dt = date -> Begin dt - | ID "BET"; dt = date; ID "AND"; dt1 = date -> BeginEnd (dt, dt1) - | ID "TO"; dt = date -> End dt - | ID "FROM"; dt = date -> Begin dt - | ID "FROM"; dt = date; ID "TO"; dt1 = date -> BeginEnd (dt, dt1) ] ] - ; - date: - [ [ ID "ABT"; (d, cal) = date_calendar -> ({(d) with prec = About}, cal) - | ID "ENV"; (d, cal) = date_calendar -> ({(d) with prec = About}, cal) - | ID "EST"; (d, cal) = date_calendar -> ({(d) with prec = Maybe}, cal) - | ID "AFT"; (d, cal) = date_calendar -> ({(d) with prec = Before}, cal) - | ID "BEF"; (d, cal) = date_calendar -> ({(d) with prec = After}, cal) - | (d, cal) = date_calendar -> (d, cal) ] ] - ; - date_calendar: - [ [ "@"; "#"; ID "DGREGORIAN"; "@"; d = date_greg -> (d, Dgregorian) - | "@"; "#"; ID "DJULIAN"; "@"; d = date_greg -> - (Calendar.gregorian_of_julian d, Djulian) - | "@"; "#"; ID "DFRENCH"; ID "R"; "@"; d = date_fren -> - (Calendar.gregorian_of_french d, Dfrench) - | "@"; "#"; ID "DHEBREW"; "@"; d = date_hebr -> - (Calendar.gregorian_of_hebrew d, Dhebrew) - | d = date_greg -> (d, Dgregorian) ] ] - ; - date_greg: - [ [ LIST0 "."; n1 = OPT int; LIST0 [ "." | "/" ]; n2 = OPT gen_month; - LIST0 [ "." | "/" ]; n3 = OPT int; LIST0 "." -> - make_date n1 n2 n3 ] ] - ; - date_fren: - [ [ LIST0 "."; n1 = int; (n2, n3) = date_fren_kont -> - make_date (Some n1) n2 n3 - | LIST0 "."; n1 = year_fren -> make_date (Some n1) None None - | LIST0 "."; (n2, n3) = date_fren_kont -> make_date None n2 n3 ] ] - ; - date_fren_kont: - [ [ LIST0 [ "." | "/" ]; n2 = OPT gen_french; LIST0 [ "." | "/" ]; - n3 = OPT year_fren; LIST0 "." -> - (n2, n3) ] ] - ; - date_hebr: - [ [ LIST0 "."; n1 = OPT int; LIST0 [ "." | "/" ]; n2 = OPT gen_hebr; - LIST0 [ "." | "/" ]; n3 = OPT int; LIST0 "." -> - make_date n1 n2 n3 ] ] - ; - gen_month: - [ [ i = int -> Left (abs i) - | m = month -> Right m ] ] - ; - month: - [ [ ID "JAN" -> 1 - | ID "FEB" -> 2 - | ID "MAR" -> 3 - | ID "APR" -> 4 - | ID "MAY" -> 5 - | ID "JUN" -> 6 - | ID "JUL" -> 7 - | ID "AUG" -> 8 - | ID "SEP" -> 9 - | ID "OCT" -> 10 - | ID "NOV" -> 11 - | ID "DEC" -> 12 ] ] - ; - gen_french: - [ [ m = french -> Right m ] ] - ; - french: - [ [ ID "VEND" -> 1 - | ID "BRUM" -> 2 - | ID "FRIM" -> 3 - | ID "NIVO" -> 4 - | ID "PLUV" -> 5 - | ID "VENT" -> 6 - | ID "GERM" -> 7 - | ID "FLOR" -> 8 - | ID "PRAI" -> 9 - | ID "MESS" -> 10 - | ID "THER" -> 11 - | ID "FRUC" -> 12 - | ID "COMP" -> 13 ] ] - ; - year_fren: - [ [ i = int -> i - | ID "AN"; i = roman_int -> i - | i = roman_int -> i ] ] - ; - gen_hebr: - [ [ m = hebr -> Right m ] ] - ; - hebr: - [ [ ID "TSH" -> 1 - | ID "CSH" -> 2 - | ID "KSL" -> 3 - | ID "TVT" -> 4 - | ID "SHV" -> 5 - | ID "ADR" -> 6 - | ID "ADS" -> 7 - | ID "NSN" -> 8 - | ID "IYR" -> 9 - | ID "SVN" -> 10 - | ID "TMZ" -> 11 - | ID "AAV" -> 12 - | ID "ELL" -> 13 ] ] - ; - int: - [ [ i = INT -> - begin - try int_of_string i with Failure _ -> raise Stream.Failure - end - | "-"; i = INT -> - begin - try (- int_of_string i) with Failure _ -> raise Stream.Failure - end ] ] - ; -END -(* [@@@ocaml.warning "+27"] *) - -let date_of_field d = - if d = "" then None - else - let s = Stream.of_string (String.uppercase_ascii d) in - date_str := d; - try Some (Grammar.Entry.parse date_value s) with - Ploc.Exc (_, Stream.Error _) -> - let s = Stream.of_string (String.uppercase_ascii d) in - try Some (Grammar.Entry.parse date_value_recover s) with - Ploc.Exc (_, Stream.Error _) -> Some (Dtext d) - -(* Creating base *) - -type 'a tab = { mutable arr : 'a array; mutable tlen : int } - -type gen = - { g_per : (string, person, ascend, union) choice3 tab; - g_fam : (string, family, couple, descend) choice3 tab; - g_str : string tab; - mutable g_bnot : string; - g_ic : in_channel; - g_not : (string, int) Hashtbl.t; - g_src : (string, int) Hashtbl.t; - g_hper : (string, Adef.iper) Hashtbl.t; - g_hfam : (string, Adef.ifam) Hashtbl.t; - g_hstr : (string, Adef.istr) Hashtbl.t; - g_hnam : (string, int ref) Hashtbl.t; - g_adop : (string, Adef.iper * string) Hashtbl.t; - mutable g_godp : (Adef.iper * Adef.iper) list; - mutable g_prelated : (Adef.iper * Adef.iper) list; - mutable g_frelated : (Adef.iper * Adef.iper) list; - mutable g_witn : (Adef.ifam * Adef.iper) list } - -let assume_tab tab none = - if tab.tlen = Array.length tab.arr then - let new_len = 2 * Array.length tab.arr + 1 in - let new_arr = Array.make new_len none in - Array.blit tab.arr 0 new_arr 0 (Array.length tab.arr); tab.arr <- new_arr - -let add_string gen s = - try Hashtbl.find gen.g_hstr s with - Not_found -> - let i = gen.g_str.tlen in - assume_tab gen.g_str ""; - gen.g_str.arr.(i) <- s; - gen.g_str.tlen <- gen.g_str.tlen + 1; - Hashtbl.add gen.g_hstr s (Adef.istr_of_int i); - Adef.istr_of_int i - -let extract_addr addr = - if String.length addr > 0 && addr.[0] = '@' then - try let r = String.index_from addr 1 '@' in String.sub addr 0 (r + 1) with - Not_found -> addr - else addr - -let per_index gen lab = - let lab = extract_addr lab in - try Hashtbl.find gen.g_hper lab with - Not_found -> - let i = gen.g_per.tlen in - assume_tab gen.g_per (Left3 ""); - gen.g_per.arr.(i) <- Left3 lab; - gen.g_per.tlen <- gen.g_per.tlen + 1; - Hashtbl.add gen.g_hper lab (Adef.iper_of_int i); - Adef.iper_of_int i - -let fam_index gen lab = - let lab = extract_addr lab in - try Hashtbl.find gen.g_hfam lab with - Not_found -> - let i = gen.g_fam.tlen in - assume_tab gen.g_fam (Left3 ""); - gen.g_fam.arr.(i) <- Left3 lab; - gen.g_fam.tlen <- gen.g_fam.tlen + 1; - Hashtbl.add gen.g_hfam lab (Adef.ifam_of_int i); - Adef.ifam_of_int i - -let string_empty = Adef.istr_of_int 0 -let string_quest = Adef.istr_of_int 1 -let string_x = Adef.istr_of_int 2 - -let unknown_per i sex = - let empty = string_empty in - let what = string_quest in - let p = - person_of_gen_person - {first_name = what; surname = what; occ = i; public_name = empty; - image = empty; qualifiers = []; aliases = []; first_names_aliases = []; - surnames_aliases = []; titles = []; rparents = []; related = []; - occupation = empty; sex = sex; access = IfTitles; - birth = Adef.cdate_None; birth_place = empty; birth_note = empty; - birth_src = empty; baptism = Adef.cdate_None; baptism_place = empty; - baptism_note = empty; baptism_src = empty; death = DontKnowIfDead; - death_place = empty; death_note = empty; death_src = empty; - burial = UnknownBurial; burial_place = empty; burial_note = empty; - burial_src = empty; pevents = []; notes = empty; psources = empty; - key_index = Adef.iper_of_int i} - and a = ascend_of_gen_ascend {parents = None; consang = Adef.fix (-1)} - and u = union_of_gen_union {family = [| |]} in - p, a, u - -let phony_per gen sex = - let i = gen.g_per.tlen in - let (person, ascend, union) = unknown_per i sex in - assume_tab gen.g_per (Left3 ""); - gen.g_per.tlen <- gen.g_per.tlen + 1; - gen.g_per.arr.(i) <- Right3 (person, ascend, union); - Adef.iper_of_int i - -let unknown_fam gen i = - let empty = string_empty in - let father = phony_per gen Male in - let mother = phony_per gen Female in - let f = - family_of_gen_family - {marriage = Adef.cdate_None; marriage_place = empty; - marriage_note = empty; marriage_src = empty; witnesses = [| |]; - relation = !relation_status; divorce = NotDivorced; fevents = []; - comment = empty; origin_file = empty; fsources = empty; - fam_index = Adef.ifam_of_int i} - and c = couple_of_gen_couple (couple false father mother) - and d = descend_of_gen_descend {children = [| |]} in - f, c, d - -let phony_fam gen = - let i = gen.g_fam.tlen in - let (fam, cpl, des) = unknown_fam gen i in - assume_tab gen.g_fam (Left3 ""); - gen.g_fam.tlen <- gen.g_fam.tlen + 1; - gen.g_fam.arr.(i) <- Right3 (fam, cpl, des); - Adef.ifam_of_int i - -let this_year = - let tm = Unix.localtime (Unix.time ()) in tm.Unix.tm_year + 1900 - -let infer_death birth bapt = - match birth, bapt with - Some (Dgreg (d, _)), _ -> - let a = this_year - d.year in - if a > !dead_years then DeadDontKnowWhen - else if a < !alive_years then NotDead - else DontKnowIfDead - | _, Some (Dgreg (d, _)) -> - let a = this_year - d.year in - if a > !dead_years then DeadDontKnowWhen - else if a < !alive_years then NotDead - else DontKnowIfDead - | _ -> DontKnowIfDead - -(* Fonctions utiles pour la mise en forme des noms. *) - -(* Hashtbl (utf8.ml) qui font la correspondance entre : *) -(* - l'encoding -> le nom *) -(* - le nom -> l'encoding *) -let (ht_e_n, ht_n_e) = - let ht_e_n = Hashtbl.create 5003 in - let ht_n_e = Hashtbl.create 5003 in - List.iter - (fun (encoding, name) -> - Hashtbl.add ht_n_e name encoding; Hashtbl.add ht_e_n encoding name) - Utf8List.utf8_list; - ht_e_n, ht_n_e - -let string_ini_eq s1 i s2 = - let rec loop i j = - if j = String.length s2 then true - else if i = String.length s1 then false - else if s1.[i] = s2.[j] then loop (i + 1) (j + 1) - else false - in - loop i 0 - -let particle s i = - let particles = - ["af "; "d'"; "d’"; "dal "; "de "; "des "; "di "; "du "; "of "; "van "; - "von und zu "; "von "; "y "; "zu "; "zur "; "AF "; "D'"; "D’"; "DAL "; - "DE "; "DES "; "DI "; "DU "; "OF "; "VAN "; "VON UND ZU "; "VON "; "Y "; - "ZU "; "ZUR "] - in - List.exists (string_ini_eq s i) particles - -let look_like_a_number s = - let rec loop i = - if i = String.length s then true - else - match s.[i] with - '0'..'9' -> loop (i + 1) - | _ -> false - in - loop 0 - -let is_a_name_char = - function - 'A'..'Z' | 'a'..'z' | '0'..'9' | '-' | '\'' -> true - | c -> Char.code c > 127 - -let rec next_word_pos s i = - if i = String.length s then i - else if is_a_name_char s.[i] then i - else next_word_pos s (i + 1) - -let rec next_sep_pos s i = - if i = String.length s then String.length s - else if is_a_name_char s.[i] then next_sep_pos s (i + 1) - else i - -let public_name_word = - ["Ier"; "Ière"; "der"; "den"; "die"; "el"; "le"; "la"; "the"] - -let rec is_a_public_name s i = - let i = next_word_pos s i in - if i = String.length s then false - else - let j = next_sep_pos s i in - if j > i then - let w = String.sub s i (j - i) in - if look_like_a_number w then true - else if is_roman_int w && s.[j] <> '.' then true - else if List.mem w public_name_word then true - else is_a_public_name s j - else false - -let gen_lowercase_uppercase_utf8_letter lower s = - (* liste des code hexa correspondant à l'encodage du caractère e. *) - let list_of_encodings e = - let rec loop len e l = - if e = "" then l - else - let i = String.index e '/' in - let j = - try String.index_from e (i + 1) '/' with - Not_found -> String.length e - in - let k = "0" ^ String.sub e (i + 1) (j - 1) in - loop (len + 1) (String.sub e j (String.length e - j)) - (int_of_string k :: l) - in - let l = loop 0 e [] in List.rev l - in - (* l'encodage du caractère s. *) - let encoding = - let rec loop i s e = - if i = String.length s then e - else - let e = e ^ Printf.sprintf "/x%x" (Char.code s.[i]) in - loop (i + 1) s e - in - loop 0 s "" - in - try - let name = Hashtbl.find ht_e_n encoding in - let name = - if lower then Str.replace_first (Str.regexp "CAPITAL") "SMALL" name - else Str.replace_first (Str.regexp "SMALL") "CAPITAL" name - in - let new_encoding = Hashtbl.find ht_n_e name in - let (el, len) = - let l = list_of_encodings new_encoding in l, List.length l - in - let s = Bytes.create len in - let rec loop i el s = - match el with - [] -> Bytes.unsafe_to_string s - | e :: ell -> let _s = Bytes.set s i (Char.chr e) in loop (i + 1) ell s - in - loop 0 el s - with Not_found -> s - -let lowercase_utf8_letter = gen_lowercase_uppercase_utf8_letter true -let uppercase_utf8_letter = gen_lowercase_uppercase_utf8_letter false - -let capitalize_word s = - let rec copy i len uncap = - if i = String.length s then Buff.get len - else - match s.[i] with - 'a'..'z' as c -> - let c = - if uncap then c - else Char.chr (Char.code c - Char.code 'a' + Char.code 'A') - in - copy (i + 1) (Buff.store len c) true - | 'A'..'Z' as c -> - let c = - if not uncap then c - else Char.chr (Char.code c - Char.code 'A' + Char.code 'a') - in - copy (i + 1) (Buff.store len c) true - | c -> - if Char.code c < 128 then - copy (i + 1) (Buff.store len c) (particle s (i + 1)) - else - let nbc = Name.nbc s.[i] in - if nbc = 1 || nbc < 0 || i + nbc > String.length s then - copy (i + 1) (Buff.store len s.[i]) true - else - let s = String.sub s i nbc in - let s = - if not uncap then uppercase_utf8_letter s - else lowercase_utf8_letter s - in - let (t, j) = s, i + nbc in copy j (Buff.mstore len t) true - in - copy 0 0 (particle s 0) - -let uppercase_word s = - let rec copy i len uncap = - if i = String.length s then Buff.get len - else - match s.[i] with - 'a'..'z' as c -> - let c = - if uncap then c - else Char.chr (Char.code c - Char.code 'a' + Char.code 'A') - in - copy (i + 1) (Buff.store len c) uncap - | 'A'..'Z' as c -> - let c = - if not uncap then c - else Char.chr (Char.code c - Char.code 'A' + Char.code 'a') - in - copy (i + 1) (Buff.store len c) uncap - | c -> - if Char.code c < 128 then - copy (i + 1) (Buff.store len c) (particle s (i + 1)) - else - let nbc = Name.nbc s.[i] in - if nbc = 1 || nbc < 0 || i + nbc > String.length s then - copy (i + 1) (Buff.store len s.[i]) false - else - let s = String.sub s i nbc in - let s = if uncap then s else uppercase_utf8_letter s in - let (t, j) = s, i + nbc in - copy j (Buff.mstore len t) false - in - copy 0 0 (particle s 0) - -module Buff2 = Buff.Make (struct end) - -let capitalize_name s = - (* On initialise le buffer à la valeur de s. *) - let _ = Buff2.mstore 0 s in - let rec loop len k = - let i = next_word_pos s k in - if i = String.length s then Buff2.get (String.length s) - else - let j = next_sep_pos s i in - if j > i then - let w = String.sub s i (j - i) in - let w = - if is_roman_int w || particle s i || List.mem w public_name_word || - start_with_int w - then - w - else capitalize_word w - in - let len = - let rec loop len k = - if k = i then len else loop (Buff2.store len s.[k]) (k + 1) - in - loop len k - in - loop (Buff2.mstore len w) j - else Buff2.get len - in - loop 0 0 - -let uppercase_name s = - (* On initialise le buffer à la valeur de s. *) - let _ = Buff2.mstore 0 s in - let rec loop len k = - let i = next_word_pos s k in - if i = String.length s then Buff2.get (String.length s) - else - let j = next_sep_pos s i in - if j > i then - let w = String.sub s i (j - i) in - let w = - if is_roman_int w || particle s i || List.mem w public_name_word || - start_with_int w - then - w - else uppercase_word w - in - let len = - let rec loop len k = - if k = i then len else loop (Buff2.store len s.[k]) (k + 1) - in - loop len k - in - loop (Buff2.mstore len w) j - else Buff2.get len - in - loop 0 0 - -let get_lev0 = - parser - [< _ = line_start '0'; _ = skip_space; r1 = get_ident 0; r2 = get_ident 0; - r3 = get_to_eoln 0 (* ? "get to eoln" *); - l = get_lev_list [] '1' (* ? "get lev list" *) >] -> - let (rlab, rval) = if r2 = "" then (r1, "") else (r2, r1) in - let rval = utf8_of_string rval in - let rcont = utf8_of_string r3 in - {rlab = rlab; rval = rval; rcont = rcont; rsons = List.rev l; - rpos = !line_cnt; rused = false} - -let find_notes_record gen addr = - match try Some (Hashtbl.find gen.g_not addr) with Not_found -> None with - Some i -> - seek_in gen.g_ic i; - begin try Some (get_lev0 (Stream.of_channel gen.g_ic)) with - Stream.Failure | Stream.Error _ -> None - end - | None -> None - -let find_sources_record gen addr = - match try Some (Hashtbl.find gen.g_src addr) with Not_found -> None with - Some i -> - seek_in gen.g_ic i; - begin try Some (get_lev '0' (Stream.of_channel gen.g_ic)) with - Stream.Failure | Stream.Error _ -> None - end - | None -> None - -let rec flatten_notes = - function - r :: rl -> - let n = flatten_notes rl in - begin match r.rlab with - "CONC" | "CONT" | "NOTE" -> - (r.rlab, r.rval) :: (flatten_notes r.rsons @ n) - | _ -> n - end - | [] -> [] - -let extract_notes gen rl = - List.fold_right - (fun r lines -> - List.fold_right - (fun r lines -> - r.rused <- true; - if r.rlab = "NOTE" && r.rval <> "" && r.rval.[0] = '@' then - let addr = extract_addr r.rval in - match find_notes_record gen addr with - Some r -> - let l = flatten_notes r.rsons in - ("NOTE", r.rcont) :: (l @ lines) - | None -> - print_location r.rpos; - Printf.fprintf !log_oc "Note %s not found\n" addr; - flush !log_oc; - lines - else (r.rlab, r.rval) :: lines) - (r :: r.rsons) lines) - rl [] - -let rebuild_text r = - let s = strip_spaces r.rval in - List.fold_left - (fun s e -> - let _ = e.rused <- true in - let n = e.rval in - let end_spc = - if String.length n > 1 && n.[String.length n - 1] = ' ' then " " - else "" - in - let n = strip_spaces n in - match e.rlab with - "CONC" -> s ^ n ^ end_spc - | "CONT" -> s ^ "
\n" ^ n ^ end_spc - | _ -> s) - s r.rsons - -let notes_from_source_record rl = - let title = - match find_field "TITL" rl with - Some l -> - let s = rebuild_text l in if s = "" then "" else "" ^ s ^ "" - | None -> "" - in - let text = - match find_field "TEXT" rl with - Some l -> - let s = rebuild_text l in if title = "" then s else "
\n" ^ s - | None -> "" - in - title ^ text - -let treat_notes gen rl = - let lines = extract_notes gen rl in - let buf = Buffer.create (List.length lines) in - let () = - List.iter - (fun (lab, n) -> - let spc = String.length n > 0 && n.[0] = ' ' in - let end_spc = String.length n > 1 && n.[String.length n - 1] = ' ' in - let n = strip_spaces n in - if Buffer.length buf = 0 then - begin - Buffer.add_string buf n; - Buffer.add_string buf (if end_spc then " " else "") - end - else if lab = "CONT" || lab = "NOTE" then - begin - Buffer.add_string buf "
\n"; - Buffer.add_string buf n; - Buffer.add_string buf (if end_spc then " " else "") - end - else if n = "" then () - else - begin - Buffer.add_string buf (if spc then "\n" else ""); - Buffer.add_string buf n; - Buffer.add_string buf (if end_spc then " " else "") - end) - lines - in - strip_newlines (Buffer.contents buf) - -let note gen r = - match find_field "NOTE" r.rsons with - Some r -> - if String.length r.rval > 0 && r.rval.[0] = '@' then - match find_notes_record gen r.rval with - Some v -> strip_spaces v.rcont, v.rsons - | None -> - print_location r.rpos; - Printf.fprintf !log_oc "Note %s not found\n" r.rval; - flush !log_oc; - "", [] - else strip_spaces r.rval, r.rsons - | _ -> "", [] - -let treat_source gen r = - if String.length r.rval > 0 && r.rval.[0] = '@' then - match find_sources_record gen r.rval with - Some v -> strip_spaces v.rcont, v.rsons - | None -> - print_location r.rpos; - Printf.fprintf !log_oc "Source %s not found\n" r.rval; - flush !log_oc; - "", [] - else strip_spaces r.rval, r.rsons - -let source gen r = - match find_field "SOUR" r.rsons with - Some r -> treat_source gen r - | _ -> "", [] - -let p_index_from s i c = - if i >= String.length s then String.length s - else try String.index_from s i c with Not_found -> String.length s - -let strip_sub s beg len = strip_spaces (String.sub s beg len) - -let decode_title s = - let i1 = p_index_from s 0 ',' in - let i2 = p_index_from s (i1 + 1) ',' in - let title = strip_sub s 0 i1 in - let (place, nth) = - if i1 = String.length s then "", 0 - else if i2 = String.length s then - let s1 = strip_sub s (i1 + 1) (i2 - i1 - 1) in - try "", int_of_string s1 with Failure _ -> s1, 0 - else - let s1 = strip_sub s (i1 + 1) (i2 - i1 - 1) in - let s2 = strip_sub s (i2 + 1) (String.length s - i2 - 1) in - try s1, int_of_string s2 with - Failure _ -> strip_sub s i1 (String.length s - i1), 0 - in - title, place, nth - -let list_of_string s = - let rec loop i len list = - if i = String.length s then List.rev (Buff.get len :: list) - else - match s.[i] with - ',' -> loop (i + 1) 0 (Buff.get len :: list) - | c -> loop (i + 1) (Buff.store len c) list - in - loop 0 0 [] - -let purge_list list = - List.fold_right - (fun s list -> - match strip_spaces s with - "" -> list - | s -> s :: list) - list [] - -let decode_date_interval pos s = - let strm = Stream.of_string s in - try - match Grammar.Entry.parse date_interval strm with - BeginEnd (d1, d2) -> Some d1, Some d2 - | Begin d -> Some d, None - | End d -> None, Some d - with Ploc.Exc (_, _) | Not_found -> print_bad_date pos s; None, None - -let treat_indi_title gen public_name r = - let (title, place, nth) = decode_title r.rval in - let (date_start, date_end) = - match find_field "DATE" r.rsons with - Some r -> decode_date_interval r.rpos r.rval - | None -> None, None - in - let (name, title, place) = - match find_field "NOTE" r.rsons with - Some r -> - if title = "" then Tnone, strip_spaces r.rval, "" - else if r.rval = public_name then Tmain, title, place - else Tname (add_string gen (strip_spaces r.rval)), title, place - | None -> Tnone, title, place - in - {t_name = name; t_ident = add_string gen title; - t_place = add_string gen place; - t_date_start = Adef.cdate_of_od date_start; - t_date_end = Adef.cdate_of_od date_end; t_nth = nth} - -let forward_pevent_witn gen ip rval = - let ipp = per_index gen rval in - gen.g_prelated <- (ipp, ip) :: gen.g_prelated; ipp - -let forward_fevent_witn gen ip rval = - let ipp = per_index gen rval in - gen.g_frelated <- (ipp, ip) :: gen.g_frelated; ipp - -let find_fevent_witness gen tag ifath r = - let rec find_witnesses = - function - [] -> [] - | r :: asso_l -> - if find_field_with_value "TYPE" tag r.rsons then - let witness = forward_fevent_witn gen ifath (strip_spaces r.rval) in - let witness_kind = - match find_field "RELA" r.rsons with - Some rr -> - if rr.rval = "GODP" then Witness_GodParent - else if rr.rval = "officer" then Witness_Officer - else Witness - | _ -> Witness - in - (witness, witness_kind) :: find_witnesses asso_l - else - let witness = forward_fevent_witn gen ifath (strip_spaces r.rval) in - let witness_kind = - match find_field "RELA" r.rsons with - Some rr -> - if rr.rval = "GODP" then Witness_GodParent - else if rr.rval = "officer" then Witness_Officer - else Witness - | _ -> Witness - in - (witness, witness_kind) :: find_witnesses asso_l - in - let witnesses = - match find_all_fields "ASSO" r.rsons with - [] -> [] - | wl -> find_witnesses wl - in - Array.of_list witnesses - -let forward_adop gen ip lab which_parent = - let which_parent = - match which_parent with - Some r -> r.rval - | _ -> "" - in - let which_parent = if which_parent = "" then "BOTH" else which_parent in - Hashtbl.add gen.g_adop lab (ip, which_parent) - -let adop_parent gen ip r = - let i = per_index gen r.rval in - match gen.g_per.arr.(Adef.int_of_iper i) with - Left3 _ -> None - | Right3 (p, a, u) -> - if List.mem ip (get_related p) then () - else - begin let p = person_with_related p (ip :: get_related p) in - gen.g_per.arr.(Adef.int_of_iper i) <- Right3 (p, a, u) - end; - Some (get_key_index p) - -let set_adop_fam gen ip which_parent fath moth = - match gen.g_per.arr.(Adef.int_of_iper ip) with - Left3 _ -> () - | Right3 (per, asc, uni) -> - let r_fath = - match which_parent, fath with - ("HUSB" | "BOTH"), Some r -> adop_parent gen ip r - | _ -> None - in - let r_moth = - match which_parent, moth with - ("WIFE" | "BOTH"), Some r -> adop_parent gen ip r - | _ -> None - in - let r = - {r_type = Adoption; r_fath = r_fath; r_moth = r_moth; - r_sources = string_empty} - in - let per = person_with_rparents per (r :: get_rparents per) in - gen.g_per.arr.(Adef.int_of_iper ip) <- Right3 (per, asc, uni) - -let forward_godp gen ip rval = - let ipp = per_index gen rval in gen.g_godp <- (ipp, ip) :: gen.g_godp; ipp - -let forward_witn gen ip rval = - let ifam = fam_index gen rval in - gen.g_witn <- (ifam, ip) :: gen.g_witn; ifam - -let glop = ref [] - -let indi_lab = - function - "ADOP" | "ASSO" | "BAPM" | "BIRT" | "BURI" | "CHR" | "CREM" | "DEAT" | - "FAMC" | "FAMS" | "NAME" | "NOTE" | "OBJE" | "OCCU" | "SEX" | "SOUR" | - "TITL" -> - true - | c -> - if List.mem c !glop then () - else - begin - glop := c :: !glop; - Printf.eprintf "untreated tag %s -> in notes\n" c; - flush stderr - end; - false - -let html_text_of_tags text rl = - let rec tot len lev r = - let len = Buff.mstore len (string_of_int lev) in - let len = Buff.store len ' ' in - let len = Buff.mstore len r.rlab in - let len = - if r.rval = "" then len else Buff.mstore (Buff.store len ' ') r.rval - in - let len = - if r.rcont = "" then len else Buff.mstore (Buff.store len ' ') r.rcont - in - totl len (lev + 1) r.rsons - and totl len lev rl = - List.fold_left - (fun len r -> let len = Buff.store len '\n' in tot len lev r) len rl - in - let title = - if text = "" then "-- GEDCOM --" else "-- GEDCOM (" ^ text ^ ") --" - in - let len = 0 in - let len = Buff.mstore len title in let len = totl len 1 rl in Buff.get len - -let rec find_all_rela nl = - function - [] -> [] - | r :: rl -> - match find_field "RELA" r.rsons with - Some r1 -> - let rec loop = - function - n :: nl1 -> - let len = String.length n in - if String.length r1.rval >= len && - String.lowercase_ascii (String.sub r1.rval 0 len) = n - then - (n, r.rval) :: find_all_rela nl rl - else loop nl1 - | [] -> find_all_rela nl rl - in - loop nl - | None -> find_all_rela nl rl - -let find_event_witness gen r = - let rec find_witnesses = - function - [] -> [] - | r :: asso_l -> - if find_field_with_value "TYPE" "INDI" r.rsons then - let witness = per_index gen r.rval in - witness :: find_witnesses asso_l - else begin r.rused <- false; find_witnesses asso_l end - in - let witnesses = - match find_all_fields "ASSO" r.rsons with - [] -> [] - | wl -> find_witnesses wl - in - let witnesses = List.map (fun ip -> ip, Witness) witnesses in - Array.of_list witnesses - -let find_pevent_name_from_tag gen tag = - match tag with - "BIRT" -> Epers_Birth - | "BAPT" -> Epers_Baptism - | "DEAT" -> Epers_Death - | "BURI" -> Epers_Burial - | "CREM" -> Epers_Cremation - | "accomplishment" -> Epers_Accomplishment - | "acquisition" -> Epers_Acquisition - | "award" -> Epers_Decoration - | "BAPL" -> Epers_BaptismLDS - | "BARM" -> Epers_BarMitzvah - | "BASM" -> Epers_BatMitzvah - | "BLES" -> Epers_Benediction - | "CENS" -> Epers_Recensement - | "circumcision" -> Epers_Circumcision - | "CONF" -> Epers_Confirmation - | "CONL" -> Epers_ConfirmationLDS - | "degree" -> Epers_Diploma - | "distinction" -> Epers_Distinction - | "dotation LDS" -> Epers_DotationLDS - | "EDUC" -> Epers_Education - | "election" -> Epers_Election - | "EMIG" -> Epers_Emigration - | "ENDL" -> Epers_Dotation - | "excommunication" -> Epers_Excommunication - | "family link LDS" -> Epers_FamilyLinkLDS - | "FCOM" -> Epers_FirstCommunion - | "funeral" -> Epers_Funeral - | "GRAD" -> Epers_Graduate - | "hospitalization" -> Epers_Hospitalisation - | "Illness" -> Epers_Illness - | "IMMI" -> Epers_Immigration - | "membership" -> Epers_Adhesion - | "military discharge" -> Epers_DemobilisationMilitaire - | "military distinction" -> Epers_MilitaryDistinction - | "military promotion" -> Epers_MilitaryPromotion - | "military service" -> Epers_MilitaryService - | "mobilisation militaire" -> Epers_MobilisationMilitaire - | "name change" -> Epers_ChangeName - | "NATU" -> Epers_Naturalisation - | "occupation" -> Epers_Occupation - | "ORDN" -> Epers_Ordination - | "passenger list" -> Epers_ListePassenger - | "PROP" -> Epers_Property - | "RESI" -> Epers_Residence - | "RETI" -> Epers_Retired - | "scellent parent LDS" -> Epers_ScellentParentLDS - | "SLGC" -> Epers_ScellentChildLDS - | "SLGS" -> Epers_ScellentSpouseLDS - | "property sale" -> Epers_VenteBien - | "WILL" -> Epers_Will - | _ -> Epers_Name (add_string gen (strip_spaces tag)) - -let primary_pevents = - ["BAPT"; "BAPL"; "BARM"; "BASM"; "BIRT"; "BLES"; "BURI"; "CENS"; "CONF"; - "CONL"; "CREM"; "DEAT"; "EDUC"; "EMIG"; "ENDL"; "FCOM"; "GRAD"; "IMMI"; - "NATU"; "ORDN"; "PROP"; "RETI"; "RESI"; "SLGS"; "SLGC"; "WILL"] - -let treat_indi_pevent gen r = - let prim_events = - List.fold_left - (fun events tag -> - List.fold_left - (fun events r -> - let name = find_pevent_name_from_tag gen tag in - let date = - match find_field "DATE" r.rsons with - Some r -> date_of_field r.rval - | None -> None - in - let place = - match find_field "PLAC" r.rsons with - Some r -> strip_spaces r.rval - | _ -> "" - in - let reason = "" in - let note = - match find_all_fields "NOTE" r.rsons with - [] -> "" - | rl -> treat_notes gen rl - in - let (src, _) = source gen r in - let witnesses = find_event_witness gen r in - let evt = - {epers_name = name; epers_date = Adef.cdate_of_od date; - epers_place = add_string gen place; - epers_reason = add_string gen reason; - epers_note = add_string gen note; - epers_src = add_string gen src; epers_witnesses = witnesses} - in - evt :: events) - events (find_all_fields tag r.rsons)) - [] primary_pevents - in - let second_events = - List.fold_left - (fun events r -> - match find_field "TYPE" r.rsons with - Some rr -> - if rr.rval <> "" then - let name = - find_pevent_name_from_tag gen - (String.lowercase_ascii rr.rval) - in - let date = - match find_field "DATE" r.rsons with - Some r -> date_of_field r.rval - | None -> None - in - let place = - match find_field "PLAC" r.rsons with - Some r -> strip_spaces r.rval - | _ -> "" - in - let reason = "" in - let note = - match find_all_fields "NOTE" r.rsons with - [] -> "" - | rl -> treat_notes gen rl - in - let (src, _) = source gen r in - let witnesses = find_event_witness gen r in - let evt = - {epers_name = name; epers_date = Adef.cdate_of_od date; - epers_place = add_string gen place; - epers_reason = add_string gen reason; - epers_note = add_string gen note; - epers_src = add_string gen src; epers_witnesses = witnesses} - in - evt :: events - else events - | None -> events) - [] (find_all_fields "EVEN" r.rsons) - in - List.rev_append prim_events second_events - -let rec build_remain_tags = - function - [] -> [] - | r :: rest -> - let rsons = if indi_lab r.rlab then [] else build_remain_tags r.rsons in - let rest = build_remain_tags rest in - if r.rused = true && rsons = [] then rest - else - {rlab = r.rlab; rval = r.rval; rcont = r.rcont; rsons = rsons; - rpos = r.rpos; rused = r.rused} :: - rest - -let applycase_surname s = - match !case_surnames with - NoCase -> s - | LowerCase -> capitalize_name s - | UpperCase -> - if !charset = Utf8 then uppercase_name s else String.uppercase_ascii s - -let reconstitute_from_pevents pevents bi bp de bu = - let found_birth = ref false in - let found_baptism = ref false in - let found_death = ref false in - let found_burial = ref false in - let rec loop pevents bi bp de bu = - match pevents with - [] -> bi, bp, de, bu - | evt :: l -> - match evt.epers_name with - Epers_Birth -> - if !found_birth then loop l bi bp de bu - else - let bi = - evt.epers_date, evt.epers_place, evt.epers_note, evt.epers_src - in - let () = found_birth := true in loop l bi bp de bu - | Epers_Baptism -> - if !found_baptism then loop l bi bp de bu - else - let bp = - evt.epers_date, evt.epers_place, evt.epers_note, evt.epers_src - in - let () = found_baptism := true in loop l bi bp de bu - | Epers_Death -> - if !found_death then loop l bi bp de bu - else - let death = - match Adef.od_of_cdate evt.epers_date with - Some d -> Death (Unspecified, Adef.cdate_of_date d) - | None -> DeadDontKnowWhen - in - let de = - death, evt.epers_place, evt.epers_note, evt.epers_src - in - let () = found_death := true in loop l bi bp de bu - | Epers_Burial -> - if !found_burial then loop l bi bp de bu - else - let bu = - Buried evt.epers_date, evt.epers_place, evt.epers_note, - evt.epers_src - in - let () = found_burial := true in loop l bi bp de bu - | Epers_Cremation -> - if !found_burial then loop l bi bp de bu - else - let bu = - Cremated evt.epers_date, evt.epers_place, evt.epers_note, - evt.epers_src - in - let () = found_burial := true in loop l bi bp de bu - | _ -> loop l bi bp de bu - in - loop pevents bi bp de bu - -let add_indi gen r = - let ip = per_index gen r.rval in - let name_sons = find_field "NAME" r.rsons in - let givn = - match name_sons with - Some n -> - begin match find_field "GIVN" n.rsons with - Some r -> r.rval - | None -> "" - end - | None -> "" - in - let (first_name, surname, occ, public_name, first_names_aliases) = - match name_sons with - Some n -> - let (f, s) = parse_name (Stream.of_string n.rval) in - let pn = givn in - let fal = if givn = f then [] else [givn] in - let (f, fal) = - match !first_names_brackets with - Some (bb, eb) -> - let first_enclosed f = - let i = String.index f bb in - let j = - if i + 2 >= String.length f then raise Not_found - else String.index_from f (i + 2) eb - in - let fn = String.sub f (i + 1) (j - i - 1) in - let fa = - String.sub f 0 i ^ fn ^ - String.sub f (j + 1) (String.length f - j - 1) - in - fn, fa - in - let rec loop first ff accu = - try - let (fn, fa) = first_enclosed ff in - let accu = - if first then fn - else if fn <> "" then accu ^ " " ^ fn - else accu - in - loop false fa accu - with Not_found -> if f = ff then f, fal else accu, ff :: fal - in - loop true f "" - | None -> f, fal - in - let (f, pn, fal) = - if !extract_public_names || !extract_first_names then - let i = next_word_pos f 0 in - let j = next_sep_pos f i in - if j = String.length f then f, pn, fal - else - let fn = String.sub f i (j - i) in - if pn = "" && !extract_public_names then - if is_a_public_name f j then fn, f, fal - else if !extract_first_names then fn, "", f :: fal - else f, "", fal - else fn, pn, f :: fal - else f, pn, fal - in - let f = if !lowercase_first_names then capitalize_name f else f in - let fal = - if !lowercase_first_names then List.map capitalize_name fal else fal - in - let pn = if capitalize_name pn = f then "" else pn in - let pn = if !lowercase_first_names then capitalize_name pn else pn in - let fal = - List.fold_right (fun fa fal -> if fa = pn then fal else fa :: fal) - fal [] - in - let s = applycase_surname s in - let r = - let key = Name.strip_lower (nominative f ^ " " ^ nominative s) in - try Hashtbl.find gen.g_hnam key with - Not_found -> let r = ref (-1) in Hashtbl.add gen.g_hnam key r; r - in - incr r; f, s, !r, pn, fal - | None -> "?", "?", Adef.int_of_iper ip, givn, [] - in - (* S'il y a des caractères interdits, on les supprime *) - let (first_name, surname) = - Name.strip_c first_name ':', Name.strip_c surname ':' - in - (* Si le prénom ou le nom est vide *) - let (first_name, surname) = - (if first_name = "" then !default_name else first_name), - (if surname = "" then !default_name else surname) - in - let qualifier = - match name_sons with - Some n -> - begin match find_field "NICK" n.rsons with - Some r -> r.rval - | None -> "" - end - | None -> "" - in - let surname_aliases = - match name_sons with - Some n -> - begin match find_field "SURN" n.rsons with - Some r -> - let list = purge_list (list_of_string r.rval) in - List.fold_right - (fun x list -> - let x = applycase_surname x in - if x <> surname then x :: list else list) - list [] - | _ -> [] - end - | None -> [] - in - let aliases = - match find_all_fields "NAME" r.rsons with - _ :: l -> List.map (fun r -> r.rval) l - | _ -> [] - in - let sex = - match find_field "SEX" r.rsons with - Some {rval = "M"} -> Male - | Some {rval = "F"} -> Female - | _ -> Neuter - in - let image = - match find_field "OBJE" r.rsons with - Some r -> - begin match find_field "FILE" r.rsons with - Some r -> if !no_picture then "" else r.rval - | None -> "" - end - | None -> "" - in - let parents = - match find_field "FAMC" r.rsons with - Some r -> Some (fam_index gen r.rval) - | None -> None - in - let occupation = - match find_all_fields "OCCU" r.rsons with - r :: rl -> - List.fold_left (fun s r -> s ^ ", " ^ strip_spaces r.rval) - (strip_spaces r.rval) rl - | [] -> "" - in - let notes = - match find_all_fields "NOTE" r.rsons with - [] -> "" - | rl -> treat_notes gen rl - in - let titles = - List.map (treat_indi_title gen public_name) - (find_all_fields "TITL" r.rsons) - in - let pevents = treat_indi_pevent gen r in - let family = - let rl = find_all_fields "FAMS" r.rsons in - let rvl = - List.fold_right - (fun r rvl -> if List.mem r.rval rvl then rvl else r.rval :: rvl) rl - [] - in - List.map (fun r -> fam_index gen r) rvl - in - let rasso = find_all_fields "ASSO" r.rsons in - let rparents = - let godparents = find_all_rela ["godf"; "godm"; "godp"] rasso in - let godparents = - if godparents = [] then - let ro = - match find_field "BAPM" r.rsons with - None -> find_field "CHR" r.rsons - | x -> x - in - if ro <> None then find_all_rela ["godf"; "godm"; "godp"] rasso - else [] - else godparents - in - let rec loop rl = - if rl <> [] then - let (r_fath, rl) = - match rl with - ("godf", r) :: rl -> Some (forward_godp gen ip r), rl - | _ -> None, rl - in - let (r_moth, rl) = - match rl with - ("godm", r) :: rl -> Some (forward_godp gen ip r), rl - | _ -> None, rl - in - let (r_fath, r_moth, rl) = - if r_fath <> None || r_moth <> None then r_fath, r_moth, rl - else - let (r_fath, rl) = - match rl with - ("godp", r) :: rl -> Some (forward_godp gen ip r), rl - | _ -> None, rl - in - r_fath, None, rl - in - let r = - {r_type = GodParent; r_fath = r_fath; r_moth = r_moth; - r_sources = string_empty} - in - r :: loop rl - else [] - in - loop godparents - in - let witn = find_all_rela ["witness"] rasso in - let () = - List.iter (fun (_, rval) -> ignore @@ forward_witn gen ip rval) witn - in - let (birth, birth_place, (birth_note, _), (birth_src, birth_nt)) = - match find_field "BIRT" r.rsons with - Some r -> - let d = - match find_field "DATE" r.rsons with - Some r -> date_of_field r.rval - | _ -> None - in - let p = - match find_field "PLAC" r.rsons with - Some r -> strip_spaces r.rval - | _ -> "" - in - let note = - match find_all_fields "NOTE" r.rsons with - [] -> "" - | rl -> treat_notes gen rl - in - d, p, (note, []), source gen r - | None -> None, "", ("", []), ("", []) - in - let (bapt, bapt_place, (bapt_note, _), (bapt_src, bapt_nt)) = - let ro = - match find_field "BAPM" r.rsons with - None -> find_field "CHR" r.rsons - | x -> x - in - match ro with - Some r -> - let d = - match find_field "DATE" r.rsons with - Some r -> date_of_field r.rval - | _ -> None - in - let p = - match find_field "PLAC" r.rsons with - Some r -> strip_spaces r.rval - | _ -> "" - in - let note = - match find_all_fields "NOTE" r.rsons with - [] -> "" - | rl -> treat_notes gen rl - in - d, p, (note, []), source gen r - | None -> None, "", ("", []), ("", []) - in - let (death, death_place, (death_note, _), (death_src, death_nt)) = - match find_field "DEAT" r.rsons with - Some r -> - if r.rsons = [] then - if r.rval = "Y" then DeadDontKnowWhen, "", ("", []), ("", []) - else infer_death birth bapt, "", ("", []), ("", []) - else - let d = - match find_field "DATE" r.rsons with - Some r -> - begin match date_of_field r.rval with - Some d -> Death (Unspecified, Adef.cdate_of_date d) - | None -> DeadDontKnowWhen - end - | _ -> DeadDontKnowWhen - in - let p = - match find_field "PLAC" r.rsons with - Some r -> strip_spaces r.rval - | _ -> "" - in - let note = - match find_all_fields "NOTE" r.rsons with - [] -> "" - | rl -> treat_notes gen rl - in - d, p, (note, []), source gen r - | None -> infer_death birth bapt, "", ("", []), ("", []) - in - let (burial, burial_place, (burial_note, _), (burial_src, burial_nt)) = - let (buri, buri_place, (buri_note, _), (buri_src, buri_nt)) = - match find_field "BURI" r.rsons with - Some r -> - if r.rsons = [] then - if r.rval = "Y" then - Buried Adef.cdate_None, "", ("", []), ("", []) - else UnknownBurial, "", ("", []), ("", []) - else - let d = - match find_field "DATE" r.rsons with - Some r -> date_of_field r.rval - | _ -> None - in - let p = - match find_field "PLAC" r.rsons with - Some r -> strip_spaces r.rval - | _ -> "" - in - let note = - match find_all_fields "NOTE" r.rsons with - [] -> "" - | rl -> treat_notes gen rl - in - Buried (Adef.cdate_of_od d), p, (note, []), source gen r - | None -> UnknownBurial, "", ("", []), ("", []) - in - let (crem, crem_place, (crem_note, _), (crem_src, crem_nt)) = - match find_field "CREM" r.rsons with - Some r -> - if r.rsons = [] then - if r.rval = "Y" then - Cremated Adef.cdate_None, "", ("", []), ("", []) - else UnknownBurial, "", ("", []), ("", []) - else - let d = - match find_field "DATE" r.rsons with - Some r -> date_of_field r.rval - | _ -> None - in - let p = - match find_field "PLAC" r.rsons with - Some r -> strip_spaces r.rval - | _ -> "" - in - let note = - match find_all_fields "NOTE" r.rsons with - [] -> "" - | rl -> treat_notes gen rl - in - Cremated (Adef.cdate_of_od d), p, (note, []), source gen r - | None -> UnknownBurial, "", ("", []), ("", []) - in - match buri, crem with - UnknownBurial, Cremated _ -> - crem, crem_place, (crem_note, []), (crem_src, crem_nt) - | _ -> buri, buri_place, (buri_note, []), (buri_src, buri_nt) - in - let birth = Adef.cdate_of_od birth in - let bapt = Adef.cdate_of_od bapt in - let (psources, psources_nt) = - let (s, s_nt) = source gen r in - if s = "" then !default_source, s_nt else s, s_nt - in - let ext_notes = - let concat_text s1 s2 s_sep = - let s = if s1 = "" && notes = "" || s2 = "" then "" else s_sep in - s1 ^ s ^ s2 - in - let text = concat_text "" (notes_from_source_record birth_nt) "
\n" in - let text = concat_text text (notes_from_source_record bapt_nt) "
\n" in - let text = - concat_text text (notes_from_source_record death_nt) "
\n" - in - let text = - concat_text text (notes_from_source_record burial_nt) "
\n" - in - let text = - concat_text text (notes_from_source_record psources_nt) "
\n" - in - if !untreated_in_notes then - let remain_tags_in_notes text init rtl = - let rtl = build_remain_tags rtl in - if rtl = [] then init - else concat_text init (html_text_of_tags text rtl) "\n" - in - let nt = remain_tags_in_notes "INDI" "" r.rsons in - let nt = remain_tags_in_notes "BIRT SOUR" nt birth_nt in - let nt = remain_tags_in_notes "BAPT SOUR" nt bapt_nt in - let nt = remain_tags_in_notes "DEAT SOUR" nt death_nt in - let nt = remain_tags_in_notes "BURI/CREM SOUR" nt burial_nt in - let nt = remain_tags_in_notes "SOUR SOUR" nt psources_nt in - if nt = "" then text else text ^ "
\n" ^ nt ^ "\n
" - else text - in - (* Mise à jour des évènements principaux. *) - let (birth_place, birth_note, birth_src) = - add_string gen birth_place, add_string gen birth_note, - add_string gen birth_src - in - let (bapt_place, bapt_note, bapt_src) = - add_string gen bapt_place, add_string gen bapt_note, - add_string gen bapt_src - in - let (death_place, death_note, death_src) = - add_string gen death_place, add_string gen death_note, - add_string gen death_src - in - let (burial_place, burial_note, burial_src) = - add_string gen burial_place, add_string gen burial_note, - add_string gen burial_src - in - (* On tri les évènements pour être sûr. *) - let pevents = - CheckItem.sort_events - ((fun evt -> CheckItem.Psort evt.epers_name), - (fun evt -> evt.epers_date)) - pevents - in - let (bi, bp, de, bu) = - reconstitute_from_pevents pevents - (birth, birth_place, birth_note, birth_src) - (bapt, bapt_place, bapt_note, bapt_src) - (death, death_place, death_note, death_src) - (burial, burial_place, burial_note, burial_src) - in - let (birth, birth_place, birth_note, birth_src) = bi in - let (bapt, bapt_place, bapt_note, bapt_src) = bp in - let (death, death_place, death_note, death_src) = de in - let (burial, burial_place, burial_note, burial_src) = bu in - let person = - person_of_gen_person - {first_name = add_string gen first_name; - surname = add_string gen surname; occ = occ; - public_name = add_string gen public_name; image = add_string gen image; - qualifiers = - if qualifier <> "" then [add_string gen qualifier] else []; - aliases = List.map (add_string gen) aliases; - first_names_aliases = List.map (add_string gen) first_names_aliases; - surnames_aliases = List.map (add_string gen) surname_aliases; - titles = titles; rparents = rparents; related = []; - occupation = add_string gen occupation; sex = sex; - access = - if !no_public_if_titles && titles <> [] then Private else IfTitles; - birth = birth; birth_place = birth_place; birth_note = birth_note; - birth_src = birth_src; baptism = bapt; baptism_place = bapt_place; - baptism_note = bapt_note; baptism_src = bapt_src; death = death; - death_place = death_place; death_note = death_note; - death_src = death_src; burial = burial; burial_place = burial_place; - burial_note = burial_note; burial_src = burial_src; pevents = pevents; - notes = add_string gen (notes ^ ext_notes); - psources = add_string gen psources; key_index = ip} - in - let ascend = - ascend_of_gen_ascend {parents = parents; consang = Adef.fix (-1)} - in - let union = union_of_gen_union {family = Array.of_list family} in - gen.g_per.arr.(Adef.int_of_iper ip) <- Right3 (person, ascend, union); - begin match find_field "ADOP" r.rsons with - Some r -> - begin match find_field "FAMC" r.rsons with - Some r -> forward_adop gen ip r.rval (find_field "ADOP" r.rsons) - | _ -> () - end - | _ -> () - end; - r.rused <- true - -let find_fevent_name_from_tag gen tag tagv = - match tag with - "MARR" -> Efam_Marriage - | "unmarried" -> Efam_NoMarriage - | "nomen" -> Efam_NoMention - | "ENGA" -> Efam_Engage - | "DIV" -> Efam_Divorce - | "SEP" | "separation" -> Efam_Separated - | "ANUL" -> Efam_Annulation - | "MARB" -> Efam_MarriageBann - | "MARC" -> Efam_MarriageContract - | "MARL" -> Efam_MarriageLicense - | "pacs" -> Efam_PACS - | "RESI" | "residence" -> Efam_Residence - | _ -> Efam_Name (add_string gen (strip_spaces tagv)) - -let primary_fevents = - ["ANUL"; "DIV"; "ENGA"; "MARR"; "MARB"; "MARC"; "MARL"; "RESI"; "SEP"] - -let treat_fam_fevent gen ifath r = - let check_place_unmarried efam_name place r = - match find_all_fields "PLAC" r.rsons with - r :: rl -> - if String.uncapitalize_ascii r.rval = "unmarried" then - Efam_NoMarriage, "" - else - let place = strip_spaces r.rval in - let rec loop = - function - r :: rl -> - if String.uncapitalize_ascii r.rval = "unmarried" then - Efam_NoMarriage, place - else loop rl - | [] -> efam_name, place - in - loop rl - | [] -> efam_name, place - in - let prim_events = - List.fold_left - (fun events tag -> - List.fold_left - (fun events r -> - let name = find_fevent_name_from_tag gen tag tag in - let date = - match find_field "DATE" r.rsons with - Some r -> date_of_field r.rval - | None -> None - in - let place = - match find_field "PLAC" r.rsons with - Some r -> strip_spaces r.rval - | _ -> "" - in - let reason = "" in - let note = - match find_all_fields "NOTE" r.rsons with - [] -> "" - | rl -> treat_notes gen rl - in - (* Si le tag 1 XXX a des infos, on les ajoutes. *) - let note = - let name_info = strip_spaces r.rval in - if name_info = "" || r.rval = "Y" then note - else name_info ^ "
\n" ^ note - in - let src = - match find_all_fields "SOUR" r.rsons with - [] -> "" - | rl -> - let rec loop first src rl = - match rl with - [] -> src - | r :: rl -> - let (src_cont, _) = treat_source gen r in - let src = - if first then src ^ src_cont - else src ^ " " ^ src_cont - in - loop false src rl - in - loop true "" rl - in - let witnesses = find_fevent_witness gen "INDI" ifath r in - (* Vérification du mariage. *) - let (name, place) = - match name with - Efam_Marriage -> - begin match find_field "TYPE" r.rsons with - Some r -> - if String.uncapitalize_ascii r.rval = "unmarried" then - Efam_NoMarriage, place - else check_place_unmarried name place r - | None -> check_place_unmarried name place r - end - | _ -> name, place - in - let evt = - {efam_name = name; efam_date = Adef.cdate_of_od date; - efam_place = add_string gen place; - efam_reason = add_string gen reason; - efam_note = add_string gen note; - efam_src = add_string gen src; efam_witnesses = witnesses} - in - (* On ajoute toujours les évènements principaux liés à la *) - (* famille, sinon, on peut avoir un problème si on supprime *) - (* l'évènement, celui ci sera remplacé par la relation par *) - (* défaut. *) - evt :: events) - events (find_all_fields tag r.rsons)) - [] primary_fevents - in - let second_events = - List.fold_left - (fun events r -> - match find_field "TYPE" r.rsons with - Some rr -> - if rr.rval <> "" then - let name = - if List.mem rr.rval primary_fevents then - find_fevent_name_from_tag gen rr.rval rr.rval - else - find_fevent_name_from_tag gen - (String.lowercase_ascii rr.rval) rr.rval - in - let date = - match find_field "DATE" r.rsons with - Some r -> date_of_field r.rval - | None -> None - in - let place = - match find_field "PLAC" r.rsons with - Some r -> strip_spaces r.rval - | _ -> "" - in - let reason = "" in - let note = - match find_all_fields "NOTE" r.rsons with - [] -> "" - | rl -> treat_notes gen rl - in - (* Si le tag 1 XXX a des infos, on les ajoutes. *) - let note = - let name_info = strip_spaces r.rval in - if name_info = "" || r.rval = "Y" then note - else name_info ^ "
\n" ^ note - in - let src = - match find_all_fields "SOUR" r.rsons with - [] -> "" - | rl -> - let rec loop first src rl = - match rl with - [] -> src - | r :: rl -> - let (src_cont, _) = treat_source gen r in - let src = - if first then src ^ src_cont - else src ^ " " ^ src_cont - in - loop false src rl - in - loop true "" rl - in - let witnesses = find_fevent_witness gen "INDI" ifath r in - let evt = - {efam_name = name; efam_date = Adef.cdate_of_od date; - efam_place = add_string gen place; - efam_reason = add_string gen reason; - efam_note = add_string gen note; - efam_src = add_string gen src; efam_witnesses = witnesses} - in - (* On ajoute que les évènements non vides, *) - (* sauf si évènement personnalisé ! *) - let has_efam_name = - match name with - Efam_Name n -> n <> string_empty - | _ -> false - in - if has_efam_name || date <> None || place <> "" || - note <> "" || src <> "" || witnesses <> [| |] - then - evt :: events - else events - else events - | None -> events) - [] (find_all_fields "EVEN" r.rsons) - in - List.rev_append prim_events second_events - -let reconstitute_from_fevents gen gay fevents marr witn div = - let found_marriage = ref false in - let found_divorce = ref false in - (* On veut cette fois ci que ce soit le dernier évènement *) - (* qui soit mis dans les évènements principaux. *) - let rec loop fevents marr witn div = - match fevents with - [] -> marr, witn, div - | evt :: l -> - match evt.efam_name with - Efam_Engage -> - if !found_marriage then loop l marr witn div - else - let witn = Array.map fst evt.efam_witnesses in - let marr = - Engaged, evt.efam_date, evt.efam_place, evt.efam_note, - evt.efam_src - in - let () = found_marriage := true in loop l marr witn div - | Efam_Marriage -> - let witn = Array.map fst evt.efam_witnesses in - let marr = - Married, evt.efam_date, evt.efam_place, evt.efam_note, - evt.efam_src - in - let () = found_marriage := true in marr, witn, div - | Efam_MarriageContract -> - if !found_marriage then loop l marr witn div - else - let witn = Array.map fst evt.efam_witnesses in - (* Pour différencier le fait qu'on recopie le *) - (* mariage, on met une précision "vers". *) - let date = - match Adef.od_of_cdate evt.efam_date with - Some (Dgreg (dmy, cal)) -> - let dmy = {dmy with prec = About} in - Adef.cdate_of_od (Some (Dgreg (dmy, cal))) - | _ -> evt.efam_date - in - (* Pour différencier le fait qu'on recopie le *) - (* mariage, on ne met pas de lieu. *) - let place = add_string gen "" in - let marr = Married, date, place, evt.efam_note, evt.efam_src in - let () = found_marriage := true in loop l marr witn div - | Efam_NoMention | Efam_MarriageBann | Efam_MarriageLicense | - Efam_Annulation | Efam_PACS -> - if !found_marriage then loop l marr witn div - else - let witn = Array.map fst evt.efam_witnesses in - let marr = - NoMention, evt.efam_date, evt.efam_place, evt.efam_note, - evt.efam_src - in - let () = found_marriage := true in loop l marr witn div - | Efam_NoMarriage -> - if !found_marriage then loop l marr witn div - else - let witn = Array.map fst evt.efam_witnesses in - let marr = - NotMarried, evt.efam_date, evt.efam_place, evt.efam_note, - evt.efam_src - in - let () = found_marriage := true in loop l marr witn div - | Efam_Divorce -> - if !found_divorce then loop l marr witn div - else - let div = Divorced evt.efam_date in - let () = found_divorce := true in loop l marr witn div - | Efam_Separated -> - if !found_divorce then loop l marr witn div - else - let div = Separated in - let () = found_divorce := true in loop l marr witn div - | _ -> loop l marr witn div - in - let (marr, witn, div) = loop (List.rev fevents) marr witn div in - (* Parents de même sexe. *) - if gay then - let (relation, date, place, note, src) = marr in - let relation = - match relation with - Married | NoSexesCheckMarried -> NoSexesCheckMarried - | _ -> NoSexesCheckNotMarried - in - let marr = relation, date, place, note, src in marr, witn, div - else marr, witn, div - -let add_fam_norm gen r adop_list = - let i = fam_index gen r.rval in - let (fath, moth, gay) = - match find_all_fields "HUSB" r.rsons, find_all_fields "WIFE" r.rsons with - [f1], [m1] -> per_index gen f1.rval, per_index gen m1.rval, false - | [f1; f2], [] -> per_index gen f1.rval, per_index gen f2.rval, true - | [], [m1; m2] -> per_index gen m1.rval, per_index gen m2.rval, true - | _ -> - let fath = - match find_field "HUSB" r.rsons with - Some r -> per_index gen r.rval - | None -> phony_per gen Male - in - let moth = - match find_field "WIFE" r.rsons with - Some r -> per_index gen r.rval - | None -> phony_per gen Female - in - fath, moth, false - in - begin match gen.g_per.arr.(Adef.int_of_iper fath) with - Left3 _ -> () - | Right3 (p, a, u) -> - let u = - if not (List.mem i (Array.to_list (get_family u))) then - union_of_gen_union {family = Array.append (get_family u) [| i |]} - else u - in - let p = if get_sex p = Neuter then person_with_sex p Male else p in - gen.g_per.arr.(Adef.int_of_iper fath) <- Right3 (p, a, u) - end; - begin match gen.g_per.arr.(Adef.int_of_iper moth) with - Left3 _ -> () - | Right3 (p, a, u) -> - let u = - if not (List.mem i (Array.to_list (get_family u))) then - union_of_gen_union {family = Array.append (get_family u) [| i |]} - else u - in - let p = if get_sex p = Neuter then person_with_sex p Female else p in - gen.g_per.arr.(Adef.int_of_iper moth) <- Right3 (p, a, u) - end; - let children = - let rl = find_all_fields "CHIL" r.rsons in - List.fold_right - (fun r ipl -> - let ip = per_index gen r.rval in - if List.mem_assoc ip adop_list then - match gen.g_per.arr.(Adef.int_of_iper ip) with - Right3 (p, a, u) -> - begin match get_parents a with - Some ifam -> - if ifam = i then - let a = ascend_with_parents a None in - gen.g_per.arr.(Adef.int_of_iper ip) <- Right3 (p, a, u); - ipl - else ip :: ipl - | None -> ip :: ipl - end - | _ -> ip :: ipl - else ip :: ipl) - rl [] - in - let (relation, marr, marr_place, (marr_note, _), (marr_src, marr_nt), - witnesses) = - let (relation, sons) = - match find_field "MARR" r.rsons with - Some r -> if gay then NoSexesCheckMarried, Some r else Married, Some r - | None -> - match find_field "ENGA" r.rsons with - Some r -> Engaged, Some r - | None -> !relation_status, None - in - match sons with - Some r -> - let (u, p) = - match find_all_fields "PLAC" r.rsons with - r :: rl -> - if String.uncapitalize_ascii r.rval = "unmarried" then - NotMarried, "" - else - let p = strip_spaces r.rval in - let rec loop = - function - r :: rl -> - if String.uncapitalize_ascii r.rval = "unmarried" then - NotMarried, p - else loop rl - | [] -> relation, p - in - loop rl - | [] -> relation, "" - in - let u = - match find_field "TYPE" r.rsons with - Some r -> - if String.uncapitalize_ascii r.rval = "gay" then - NoSexesCheckNotMarried - else u - | None -> u - in - let d = - match find_field "DATE" r.rsons with - Some r -> date_of_field r.rval - | _ -> None - in - let rec heredis_witnesses = - function - [] -> [] - | r :: asso_l -> - if find_field_with_value "RELA" "Witness" r.rsons && - find_field_with_value "TYPE" "INDI" r.rsons - then - let witness = per_index gen r.rval in - witness :: heredis_witnesses asso_l - else begin r.rused <- false; heredis_witnesses asso_l end - in - let witnesses = - match find_all_fields "ASSO" r.rsons with - [] -> [] - | wl -> heredis_witnesses wl - in - let note = - match find_all_fields "NOTE" r.rsons with - [] -> "" - | rl -> treat_notes gen rl - in - u, d, p, (note, []), source gen r, witnesses - | None -> relation, None, "", ("", []), ("", []), [] - in - let witnesses = Array.of_list witnesses in - let div = - match find_field "DIV" r.rsons with - Some r -> - begin match find_field "DATE" r.rsons with - Some d -> Divorced (Adef.cdate_of_od (date_of_field d.rval)) - | _ -> - match find_field "PLAC" r.rsons with - Some _ -> Divorced Adef.cdate_None - | _ -> - if r.rval = "Y" then Divorced Adef.cdate_None - else NotDivorced - end - | None -> NotDivorced - in - let fevents = treat_fam_fevent gen fath r in - let comment = - match find_all_fields "NOTE" r.rsons with - [] -> "" - | rl -> treat_notes gen rl - in - let (fsources, fsources_nt) = - let (s, s_nt) = source gen r in - if s = "" then !default_source, s_nt else s, s_nt - in - let concat_text s1 s2 s_sep = - let s = if s1 = "" then "" else s_sep in s1 ^ s ^ s2 - in - let ext_sources = - let text = concat_text "" (notes_from_source_record marr_nt) "
\n" in - concat_text text (notes_from_source_record fsources_nt) "
\n" - in - let ext_notes = - if !untreated_in_notes then - let remain_tags_in_notes text init rtl = - let rtl = build_remain_tags rtl in - if rtl = [] then init - else concat_text init (html_text_of_tags text rtl) "\n" - in - let nt = remain_tags_in_notes "FAM" "" r.rsons in - let nt = remain_tags_in_notes "MARR SOUR" nt marr_nt in - let nt = remain_tags_in_notes "SOUR SOUR" nt fsources_nt in - if nt = "" then "" else "
\n" ^ nt ^ "\n
" - else "" - in - let add_in_person_notes iper = - match gen.g_per.arr.(Adef.int_of_iper iper) with - Left3 _ -> () - | Right3 (p, a, u) -> - let notes = gen.g_str.arr.(Adef.int_of_istr (get_notes p)) in - let notes = - if notes = "" then ext_sources ^ ext_notes - else if ext_sources = "" then notes ^ "\n" ^ ext_notes - else notes ^ "
\n" ^ ext_sources ^ ext_notes - in - let new_notes = add_string gen notes in - let p = - person_of_gen_person - {(gen_person_of_person p) with notes = new_notes} - in - gen.g_per.arr.(Adef.int_of_iper iper) <- Right3 (p, a, u) - in - let _ = - if ext_notes = "" then () - else begin add_in_person_notes fath; add_in_person_notes moth end - in - (* Mise à jour des évènements principaux. *) - let (marr, marr_place, marr_note, marr_src) = - Adef.cdate_of_od marr, add_string gen marr_place, - add_string gen marr_note, add_string gen marr_src - in - (* On tri les évènements pour être sûr. *) - let fevents = - CheckItem.sort_events - ((fun evt -> CheckItem.Fsort evt.efam_name), (fun evt -> evt.efam_date)) - fevents - in - let (marr, witn, div) = - reconstitute_from_fevents gen gay fevents - (relation, marr, marr_place, marr_note, marr_src) witnesses div - in - let (relation, marr, marr_place, marr_note, marr_src) = marr in - let witnesses = witn in - let div = div in - let fam = - family_of_gen_family - {marriage = marr; marriage_place = marr_place; - marriage_note = marr_note; marriage_src = marr_src; - witnesses = witnesses; relation = relation; divorce = div; - fevents = fevents; comment = add_string gen comment; - origin_file = string_empty; fsources = add_string gen fsources; - fam_index = i} - and cpl = couple_of_gen_couple (couple false fath moth) - and des = descend_of_gen_descend {children = Array.of_list children} in - gen.g_fam.arr.(Adef.int_of_ifam i) <- Right3 (fam, cpl, des) - -let add_fam gen r = - let list = Hashtbl.find_all gen.g_adop r.rval in - match list with - [] -> add_fam_norm gen r [] - | list -> - let husb = find_field "HUSB" r.rsons in - let wife = find_field "WIFE" r.rsons in - List.iter - (fun (ip, which_parent) -> set_adop_fam gen ip which_parent husb wife) - list; - match find_field "CHIL" r.rsons with - Some _ -> add_fam_norm gen r list - | _ -> () - -let treat_header2 r = - match !charset_option with - Some v -> charset := v - | None -> - match find_field "CHAR" r.rsons with - Some r -> - begin match r.rval with - "ANSEL" -> charset := Ansel - | "ASCII" | "IBMPC" -> charset := Ascii - | "MACINTOSH" -> charset := MacIntosh - | "UTF-8" -> charset := Utf8 - | _ -> charset := Ascii - end - | None -> () - -let treat_header3 gen r = - match find_all_fields "NOTE" r.rsons with - [] -> () - | rl -> gen.g_bnot <- treat_notes gen rl - -let turn_around_genealogos_bug r = - if String.length r.rlab > 0 && r.rlab.[0] = '@' then - {r with rlab = r.rval; rval = r.rlab} - else r - -let make_gen2 gen r = - let r = turn_around_genealogos_bug r in - match r.rlab with - "HEAD" -> treat_header2 r - | "INDI" -> add_indi gen r - | _ -> () - -let make_gen3 gen r = - let r = turn_around_genealogos_bug r in - match r.rlab with - "HEAD" -> treat_header3 gen r - | "SUBM" -> () - | "INDI" -> () - | "FAM" -> add_fam gen r - | "NOTE" -> () - | "SOUR" -> () - | "TRLR" -> Printf.eprintf "*** Trailer ok\n"; flush stderr - | s -> Printf.fprintf !log_oc "Not implemented typ = %s\n" s; flush !log_oc - -let find_lev0 = - parser bp - [< _ = line_start '0'; _ = skip_space; r1 = get_ident 0; r2 = get_ident 0; - _ = skip_to_eoln >] -> - (bp, r1, r2) - -let pass1 gen fname = - let ic = open_in_bin fname in - let strm = Stream.of_channel ic in - let rec loop () = - match try Some (find_lev0 strm) with Stream.Failure -> None with - Some (bp, r1, r2) -> - begin match r2 with - "NOTE" -> Hashtbl.add gen.g_not r1 bp - | "SOUR" -> Hashtbl.add gen.g_src r1 bp - | _ -> () - end; - loop () - | None -> - match strm with parser - | [< '_ >] -> skip_to_eoln strm; loop () - | [< >] -> () - in - loop (); close_in ic - -let pass2 gen fname = - let ic = open_in_bin fname in - line_cnt := 0; - let strm = - Stream.from - (fun _ -> - try - let c = input_char ic in if c = '\n' then incr line_cnt; Some c - with End_of_file -> None) - in - let rec loop () = - match try Some (get_lev0 strm) with Stream.Failure -> None with - Some r -> make_gen2 gen r; loop () - | None -> - match strm with parser - | [< ''1'..'9' >] -> - let _ : string = get_to_eoln 0 strm in - loop () - | [< '_ >] -> - let _ : string = get_to_eoln 0 strm in - loop () - | [< >] -> () - in - loop (); - List.iter - (fun (ipp, ip) -> - match gen.g_per.arr.(Adef.int_of_iper ipp) with - Right3 (p, a, u) -> - if List.mem ip (get_related p) then () - else - let p = person_with_related p (ip :: get_related p) in - gen.g_per.arr.(Adef.int_of_iper ipp) <- Right3 (p, a, u) - | _ -> ()) - gen.g_godp; - List.iter - (fun (ipp, ip) -> - match gen.g_per.arr.(Adef.int_of_iper ipp) with - Right3 (p, a, u) -> - if List.mem ip (get_related p) then () - else - let p = person_with_related p (ip :: get_related p) in - gen.g_per.arr.(Adef.int_of_iper ipp) <- Right3 (p, a, u) - | _ -> ()) - gen.g_prelated; - close_in ic - -let pass3 gen fname = - let ic = open_in_bin fname in - line_cnt := 0; - let strm = - Stream.from - (fun _ -> - try - let c = input_char ic in if c = '\n' then incr line_cnt; Some c - with End_of_file -> None) - in - let rec loop () = - match try Some (get_lev0 strm) with Stream.Failure -> None with - Some r -> make_gen3 gen r; loop () - | None -> - match strm with parser - | [< ''1'..'9' >] -> - let _ : string = get_to_eoln 0 strm in - loop () - | [< '_ >] -> - print_location (!line_cnt); - Printf.fprintf (!log_oc) "Strange input.\n"; - flush (!log_oc); - let _ : string = get_to_eoln 0 strm in - loop () - | [< >] -> () - in - loop (); - List.iter - (fun (ifam, ip) -> - match gen.g_fam.arr.(Adef.int_of_ifam ifam) with - Right3 (fam, cpl, des) -> - begin match - gen.g_per.arr.(Adef.int_of_iper (get_father cpl)), - gen.g_per.arr.(Adef.int_of_iper ip) - with - Right3 _, Right3 (p, a, u) -> - if List.mem (get_father cpl) (get_related p) then () - else - begin let p = - person_with_related p (get_father cpl :: get_related p) - in - gen.g_per.arr.(Adef.int_of_iper ip) <- Right3 (p, a, u) - end; - if List.mem ip (Array.to_list (get_witnesses fam)) then () - else - let fam = - family_of_gen_family - {(gen_family_of_family fam) with witnesses = - Array.append (get_witnesses fam) [| ip |]} - in - gen.g_fam.arr.(Adef.int_of_ifam ifam) <- - Right3 (fam, cpl, des) - | _ -> () - end - | _ -> ()) - gen.g_witn; - List.iter - (fun (ipp, ip) -> - match gen.g_per.arr.(Adef.int_of_iper ipp) with - Right3 (p, a, u) -> - if List.mem ip (get_related p) then () - else - let p = person_with_related p (ip :: get_related p) in - gen.g_per.arr.(Adef.int_of_iper ipp) <- Right3 (p, a, u) - | _ -> ()) - gen.g_frelated; - close_in ic - -let check_undefined gen = - for i = 0 to gen.g_per.tlen - 1 do - match gen.g_per.arr.(i) with - Right3 (_, _, _) -> () - | Left3 lab -> - let (p, a, u) = unknown_per i Neuter in - Printf.fprintf !log_oc "Warning: undefined person %s\n" lab; - gen.g_per.arr.(i) <- Right3 (p, a, u) - done; - for i = 0 to gen.g_fam.tlen - 1 do - match gen.g_fam.arr.(i) with - Right3 (_, _, _) -> () - | Left3 lab -> - let (f, c, d) = unknown_fam gen i in - Printf.fprintf !log_oc "Warning: undefined family %s\n" lab; - gen.g_fam.arr.(i) <- Right3 (f, c, d) - done - -let add_parents_to_isolated gen = - for i = 0 to gen.g_per.tlen - 1 do - match gen.g_per.arr.(i) with - Right3 (p, a, u) -> - if get_parents a = None && Array.length (get_family u) = 0 && - get_rparents p = [] && get_related p = [] - then - let fn = gen.g_str.arr.(Adef.int_of_istr (get_first_name p)) in - let sn = gen.g_str.arr.(Adef.int_of_istr (get_surname p)) in - if fn = "?" && sn = "?" then () - else - begin - Printf.fprintf !log_oc "Adding parents to isolated person: %s.%d %s\n" - fn (get_occ p) sn; - let ifam = phony_fam gen in - match gen.g_fam.arr.(Adef.int_of_ifam ifam) with - Right3 (fam, cpl, _) -> - let des = - descend_of_gen_descend {children = [| get_key_index p |]} - in - gen.g_fam.arr.(Adef.int_of_ifam ifam) <- - Right3 (fam, cpl, des); - let a = ascend_with_parents a (Some ifam) in - gen.g_per.arr.(i) <- Right3 (p, a, u) - | _ -> () - end - | Left3 _ -> () - done - -let make_arrays in_file = - let fname = - if Filename.check_suffix in_file ".ged" then in_file - else if Filename.check_suffix in_file ".GED" then in_file - else in_file ^ ".ged" - in - let gen = - {g_per = {arr = [| |]; tlen = 0}; g_fam = {arr = [| |]; tlen = 0}; - g_str = {arr = [| |]; tlen = 0}; g_bnot = ""; g_ic = open_in_bin fname; - g_not = Hashtbl.create 3001; g_src = Hashtbl.create 3001; - g_hper = Hashtbl.create 3001; g_hfam = Hashtbl.create 3001; - g_hstr = Hashtbl.create 3001; g_hnam = Hashtbl.create 3001; - g_adop = Hashtbl.create 3001; g_godp = []; g_prelated = []; - g_frelated = []; g_witn = []} - in - assert (add_string gen "" = string_empty); - assert (add_string gen "?" = string_quest); - assert (add_string gen "x" = string_x); - Printf.eprintf "*** pass 1 (note)\n"; - flush stderr; - pass1 gen fname; - Printf.eprintf "*** pass 2 (indi)\n"; - flush stderr; - pass2 gen fname; - Printf.eprintf "*** pass 3 (fam)\n"; - flush stderr; - pass3 gen fname; - close_in gen.g_ic; - check_undefined gen; - add_parents_to_isolated gen; - gen.g_per, gen.g_fam, gen.g_str, gen.g_bnot - -let make_subarrays (g_per, g_fam, g_str, g_bnot) = - let persons = - let pa = Array.make g_per.tlen (Obj.magic 0) in - let aa = Array.make g_per.tlen (Obj.magic 0) in - let ua = Array.make g_per.tlen (Obj.magic 0) in - for i = 0 to g_per.tlen - 1 do - match g_per.arr.(i) with - Right3 (p, a, u) -> pa.(i) <- p; aa.(i) <- a; ua.(i) <- u - | Left3 lab -> failwith ("undefined person " ^ lab) - done; - pa, aa, ua - in - let families = - let fa = Array.make g_fam.tlen (Obj.magic 0) in - let ca = Array.make g_fam.tlen (Obj.magic 0) in - let da = Array.make g_fam.tlen (Obj.magic 0) in - for i = 0 to g_fam.tlen - 1 do - match g_fam.arr.(i) with - Right3 (f, c, d) -> fa.(i) <- f; ca.(i) <- c; da.(i) <- d - | Left3 lab -> failwith ("undefined family " ^ lab) - done; - fa, ca, da - in - let strings = Array.sub g_str.arr 0 g_str.tlen in - persons, families, strings, g_bnot - -(* Converting to Gwcomp.gw_syntax *) - -let key_of_person sa p = - {Gwcomp.pk_first_name = sa.(Adef.int_of_istr p.first_name); - pk_surname = sa.(Adef.int_of_istr p.surname); pk_occ = p.occ} - -let somebody_of_person def pa sa ip = - let p = pa.(Adef.int_of_iper ip) in - let somebody = - if def.(Adef.int_of_iper ip) then - let pk = key_of_person sa p in Gwcomp.Undefined pk - else - let p = {p with rparents = []; related = []; notes = string_empty} in - let p = - Futil.map_person_ps (fun _ -> failwith "somebody_of_person") - (fun i -> sa.(Adef.int_of_istr i)) p - in - def.(Adef.int_of_iper ip) <- true; Gwcomp.Defined p - in - somebody, p.sex - -let string_person_of_person pa sa ip = - Futil.map_person_ps (fun p -> p) (fun i -> sa.(Adef.int_of_istr i)) - pa.(Adef.int_of_iper ip) - -let make_gwsyntax ((pa, _, _), (fa, ca, da), sa, g_bnot) = - let rev_list = ref [] in - let def = Array.make (Array.length pa) false in - for ifam = 0 to Array.length fa - 1 do - let des = da.(ifam) in - for i = 0 to Array.length des.children - 1 do - def.(Adef.int_of_iper des.children.(i)) <- true - done - done; - for ifam = 0 to Array.length fa - 1 do - let cpl = ca.(ifam) in - let (fath, s1) = somebody_of_person def pa sa (Adef.father cpl) in - let (moth, s2) = somebody_of_person def pa sa (Adef.mother cpl) in - let cpl = Adef.couple fath moth in - let witn = - List.map (somebody_of_person def pa sa) - (Array.to_list fa.(ifam).witnesses) - in - let fevents = - List.map - (fun evt -> - let name = - match evt.efam_name with - Efam_Name n -> Efam_Name sa.(Adef.int_of_istr n) - | Efam_Marriage | Efam_NoMarriage | Efam_NoMention | - Efam_Engage | Efam_Divorce | Efam_Separated | Efam_Annulation | - Efam_MarriageBann | Efam_MarriageContract | - Efam_MarriageLicense | Efam_PACS | Efam_Residence as e -> - e - in - let witl = - List.map - (fun (ip, wk) -> - let (sb, sex) = somebody_of_person def pa sa ip in - sb, sex, wk) - (Array.to_list evt.efam_witnesses) - in - name, evt.efam_date, sa.(Adef.int_of_istr evt.efam_place), - sa.(Adef.int_of_istr evt.efam_reason), - sa.(Adef.int_of_istr evt.efam_note), - sa.(Adef.int_of_istr evt.efam_src), witl) - fa.(ifam).fevents - in - let fam = - let fam = {fa.(ifam) with witnesses = [| |]; fevents = []} in - Futil.map_family_ps (fun _ -> failwith "make_gwsyntax 1") - (fun i -> sa.(Adef.int_of_istr i)) fam - in - let des = Futil.map_descend_p (string_person_of_person pa sa) da.(ifam) in - rev_list := - Gwcomp.Family (cpl, s1, s2, witn, fevents, fam, des) :: !rev_list - done; - for i = 0 to Array.length pa - 1 do - match pa.(i).rparents with - [] -> () - | rl -> - let (x, sex) = somebody_of_person def pa sa (Adef.iper_of_int i) in - let rl = - List.map - (fun r -> - Futil.map_relation_ps - (fun ip -> fst (somebody_of_person def pa sa ip)) - (fun i -> sa.(Adef.int_of_istr i)) r) - rl - in - rev_list := Gwcomp.Relations (x, sex, rl) :: !rev_list - done; - for i = 0 to Array.length pa - 1 do - let p = pa.(i) in - let n = sa.(Adef.int_of_istr p.notes) in - if n = "" then () - else - let pk = key_of_person sa p in - rev_list := Gwcomp.Notes (pk, n) :: !rev_list - done; - if g_bnot = "" then () - else rev_list := Gwcomp.Bnotes ("", g_bnot) :: !rev_list; - List.rev !rev_list - -(* Providing gw_syntax stream *) - -let next_family_fun_templ gw_syntax in_file fi = - fi.Db2link.f_curr_gwo_file <- in_file; - let gw_syntax = ref gw_syntax in - fun () -> - match !gw_syntax with - x :: l -> gw_syntax := l; Some x - | [] -> None - -(* Main *) - -let set_undefined_death_interval s = - try - match Stream.of_string s with parser - | [< a = number 0; ''-'; b = number 0 >] -> - Printf.eprintf "ay %s dy %s\n" a b; - flush stderr; - let a = if a = "" then ! alive_years else int_of_string a in - let b = max a (if b = "" then ! dead_years else int_of_string b) in - alive_years := a; - dead_years := b; - Printf.eprintf "ay %d dy %d\n" a b; - flush stderr - with - | Stream.Error _ -> raise (Arg.Bad "bad parameter for -udi") - | e -> raise e - -let out_file = ref "a" -let speclist = - ["-o", Arg.String (fun s -> out_file := s), - "\n Output database (default: \"a\")."; - "-f", Arg.Set force, "\n Remove database if already existing"; - "-log", Arg.String (fun s -> log_oc := open_out s), - "\n Redirect log trace to this file."; - "-lf", Arg.Set lowercase_first_names, - " - Lowercase first names -\n \ - Convert first names to lowercase letters, with initials in \ - uppercase."; - "-ls", Arg.Unit (fun () -> case_surnames := LowerCase), - " - Lowercase surnames -\n \ - Convert surnames to lowercase letters, with initials in \ - uppercase. Try to keep lowercase particles."; - "-us", Arg.Unit (fun () -> case_surnames := UpperCase), - " - Uppercase surnames -\n \ - Convert surnames to uppercase letters."; - "-fne", - Arg.String - (fun s -> - if String.length s = 2 then - first_names_brackets := Some (s.[0], s.[1]) - else - raise - (Arg.Bad - "-fne option must be followed by a 2 characters string")), - "be - First names enclosed -\n \ - When creating a person, if the GEDCOM first name part holds \ - a part between 'b' (any character) and 'e' (any character), it \ - is considered to be the usual first name: e.g. -fne '\"\"' or \ - -fne \"()\"."; - "-efn", Arg.Set extract_first_names, - " - Extract first names -\n \ - When creating a person, if the GEDCOM first name part holds several \ - names, the first of this names becomes the person \"first name\" and \ - the complete GEDCOM first name part a \"first name alias\"."; - "-no_efn", Arg.Clear extract_first_names, - " - Don't extract first names - [default] \ - Cancels the previous option."; - "-epn", Arg.Set extract_public_names, - " - Extract public names - [default] \n \ - When creating a person, if the GEDCOM first name part looks like a \ - public name, i.e. holds:\n \ - * a number or a roman number, supposed to be a number of a \ - nobility title,\n \ - * one of the words: \"der\", \"den\", \"die\", \"el\", \"le\", \"la\", \ - \"the\", supposed to be the beginning of a qualifier, \ - then the GEDCOM first name part becomes the person \"public name\" \ - and its first word his \"first name\"."; - "-no_epn", Arg.Clear extract_public_names, - "\n Cancels the previous option."; - "-no_pit", Arg.Set no_public_if_titles, - " - No public if titles -\n \ - Do not consider persons having titles as public"; - "-tnd", Arg.Set try_negative_dates, - " - Try negative dates -\n \ - Set negative dates when inconsistency (e.g. birth after death)"; - "-no_nd", Arg.Set no_negative_dates, - " - No negative dates -\n \ - Don't interpret a year preceded by a minus sign as a negative year"; - "-nc", Arg.Clear Db2link.do_check, "\n No consistency check"; - "-nopicture", Arg.Set no_picture, " - Don't extract individual picture."; - "-udi", Arg.String set_undefined_death_interval, - "x-y - Undefined death interval -\n \ - Set the interval for persons whose death part is undefined:\n \ - - if before x years, they are considered as alive\n \ - - if after y year, they are considered as death\n \ - - between x and y year, they are considered as \"don't know\"\n \ - Default x is " - ^ string_of_int !alive_years ^ " and y is " ^ string_of_int !dead_years; - "-uin", Arg.Set untreated_in_notes, - " - Untreated in notes -\n Put untreated GEDCOM tags in notes"; - "-ds", Arg.String (fun s -> default_source := s), - " - Default source -\n \ - Set the source field for persons and families without source data"; - "-dn", Arg.String (fun s -> default_name := s), - " - Default name -\n \ - Set the first name or surname field for persons without name"; - "-dates_dm", Arg.Unit (fun () -> month_number_dates := DayMonthDates), - "\n Interpret months-numbered dates as day/month/year"; - "-dates_md", Arg.Unit (fun () -> month_number_dates := MonthDayDates), - "\n Interpret months-numbered dates as month/day/year"; - "-rs_no_mention", Arg.Unit (fun () -> relation_status := NoMention), - "\n Force relation status to NoMention (default is Married)"; - "-charset", - Arg.String - (function - "ANSEL" -> charset_option := Some Ansel - | "ASCII" -> charset_option := Some Ascii - | "MSDOS" -> charset_option := Some Msdos - | _ -> raise (Arg.Bad "bad -charset value")), - "[ANSEL|ASCII|MSDOS] - charset decoding -\n \ - Force given charset decoding, overriding the possible setting in \ - GEDCOM"] - -let anonfun s = - if !in_file = "" then in_file := s - else raise (Arg.Bad "Cannot treat several GEDCOM files") - -let errmsg = "Usage: ged2gwb2 [] [options] where options are:" - -let main () = - Argl.parse speclist anonfun errmsg; - Secure.set_base_dir (Filename.dirname !out_file); - let bdir = - if Filename.check_suffix !out_file ".gwb" then !out_file - else !out_file ^ ".gwb" - in - if not !force && Sys.file_exists bdir then - begin - Printf.printf "The database \"%s\" already exists. \ - Use option -f to overwrite it." - !out_file; - flush stdout; - exit 2 - end; - let gw_syntax = - let arrays = make_arrays !in_file in - Gc.compact (); - let arrays = make_subarrays arrays in flush !log_oc; make_gwsyntax arrays - in - Lock.control (Mutil.lock_file !out_file) false - (fun () -> - let next_family_fun = next_family_fun_templ gw_syntax !in_file in - if Db2link.link next_family_fun bdir then () - else (Printf.eprintf "*** database not created\n"; flush stderr; exit 2)) - ~onerror:Lock.print_error_and_exit; - (* - finish_base base arrays; - *) - warning_month_number_dates (); - if !log_oc != stdout then close_out !log_oc - -let _ = - try main () with - e -> - let e = - match e with - Ploc.Exc (_, e) -> e - | _ -> e - in - Printf.fprintf !log_oc "Uncaught exception: %s\n" (Printexc.to_string e); - if !log_oc != stdout then close_out !log_oc; - exit 2 diff --git a/bin/distrib/gwc/gwc2.ml b/bin/distrib/gwc/gwc2.ml deleted file mode 100644 index 88691b109f..0000000000 --- a/bin/distrib/gwc/gwc2.ml +++ /dev/null @@ -1,196 +0,0 @@ - -(* Copyright (c) 2006-2007 INRIA *) - -open Geneweb -open Gwcomp - -(* ******************************************************************** *) -(* [Fonc] check_magic : string -> in_channel -> unit *) -(** [Description] : Vérifie le header du fichier passé en paramètre tel - que défini par magic_gwo - [Args] : - - fname : nom du fichier. - - ic : descripteur du fichier. - [Retour] : Si le header n'est pas compatible, on quite en lançant - une exception Failure suivie du message d'erreur. - [Rem] : Non exporté en clair hors de ce module. *) -(* ******************************************************************** *) -let check_magic fname ic = - let b = really_input_string ic (String.length magic_gwo) in - if b <> magic_gwo then - if String.sub magic_gwo 0 4 = String.sub b 0 4 then - failwith - ("\"" ^ fname ^ "\" is a GeneWeb object file, but not compatible") - else - failwith - ("\"" ^ fname ^ - "\" is not a GeneWeb object file, or it is a very old version") - -let next_family_fun_templ gwo_list fi = - let ngwo = List.length gwo_list in - let run = - if ngwo < 10 || not !(Mutil.verbose) then fun () -> () - else if ngwo < 60 then fun () -> Printf.eprintf "."; flush stderr - else - let bar_cnt = ref 0 in - let run () = ProgrBar.run !bar_cnt ngwo; incr bar_cnt in - ProgrBar.empty := 'o'; ProgrBar.full := '*'; ProgrBar.start (); run - in - let ic_opt = ref None in - let gwo_list = ref gwo_list in - fi.Db2link.f_sep_file_inx <- 0; - fun () -> - let rec loop () = - let r = - match !ic_opt with - Some ic -> - begin match - (try Some (input_value ic : gw_syntax) with End_of_file -> None) - with - Some fam -> Some fam - | None -> - close_in ic; - ic_opt := None; - fi.Db2link.f_sep_file_inx <- fi.Db2link.f_sep_file_inx + 1; - None - end - | None -> None - in - match r with - Some fam -> Some fam - | None -> - match !gwo_list with - (x, separate, _) :: rest -> - run (); - gwo_list := rest; - let ic = open_in_bin x in - check_magic x ic; - fi.Db2link.f_curr_src_file <- input_value ic; - fi.Db2link.f_curr_gwo_file <- x; - fi.Db2link.f_separate <- separate; - fi.Db2link.f_has_separates <- - fi.Db2link.f_has_separates || separate; - ic_opt := Some ic; - loop () - | [] -> - if ngwo < 10 || not !(Mutil.verbose) then () - else if ngwo < 60 then - begin Printf.eprintf "\n"; flush stderr end - else ProgrBar.finish (); - None - in - loop () - -let just_comp = ref false -let out_file = ref (Filename.concat Filename.current_dir_name "a") -let force = ref false - -let separate = ref false -let shift = ref 0 -let files = ref [] - -(* ******************************************************************** *) -(* [Var] speclist : (string * Arg.spec * string) list *) -(** [Description] : Positionne les variables en fonction des options - données à gwc2 - [Rem] : Non exporté en clair hors de ce module. *) -(* ******************************************************************** *) -let speclist = - ["-c", Arg.Set just_comp, "Only compiling"; - "-o", Arg.String (fun s -> out_file := s), - " Output database (default: a.gwb)"; - "-f", Arg.Set force, " Remove database if already existing"; - "-stats", Arg.Set Db2link.pr_stats, "Print statistics"; - "-nc", Arg.Clear Db2link.do_check, "No consistency check"; - "-cg", Arg.Set Db2link.do_consang, "Compute consanguinity"; - "-sep", Arg.Set separate, " Separate all persons in next file"; - "-sh", Arg.Int (fun x -> shift := x), - " Shift all persons numbers in next files"; - "-ds", Arg.String (fun s -> Db2link.default_source := s), "\ - Set the source field for persons and families without source data"; - "-part", Arg.String (fun s -> Db2link.particules_file := s), "\ - Particles file (default = predefined particles)"; - "-mem", Arg.Unit (fun () -> ()), " (obsolete option)"; - "-nolock", Arg.Set Lock.no_lock_flag, " do not lock database."; - "-nofail", Arg.Set Gwcomp.no_fail, " no failure in case of error."; - "-nopicture", Arg.Set Gwcomp.no_picture, - " do not create associative pictures"; - "-q", Arg.Clear Mutil.verbose, " no verbose"; - "-v", Arg.Set Mutil.verbose, " verbose"] - -let anonfun x = - let sep = !separate in - if Filename.check_suffix x ".gw" then () - else if Filename.check_suffix x ".gwo" then () - else raise (Arg.Bad ("Don't know what to do with \"" ^ x ^ "\"")); - separate := false; - files := (x, sep, !shift) :: !files - -let errmsg = - "Usage: gwc2 [options] [files]\n\ - where [files] are a list of files:\n \ - source files end with .gw\n \ - object files end with .gwo\n\ - and [options] are:" - -(* ******************************************************************** *) -(* [Fonc] main : unit -> unit *) -(** [Description] : Fonction principale de création d'une base au - format gwb2. - [Args] : Néant. - [Retour] : Néant. - [Rem] : Non exporté en clair hors de ce module. *) -(* ******************************************************************** *) -let main () = - Mutil.verbose := false; - Argl.parse speclist anonfun errmsg; - Secure.set_base_dir (Filename.dirname !out_file); - let gwo = ref [] in - List.iter - (fun (x, separate, shift) -> - if Filename.check_suffix x ".gw" then - begin - begin try Gwcomp.comp_families x with - e -> Printf.printf "File \"%s\", line %d:\n" x !line_cnt; raise e - end; - gwo := (x ^ "o", separate, shift) :: !gwo - end - else if Filename.check_suffix x ".gwo" then - gwo := (x, separate, shift) :: !gwo - else raise (Arg.Bad ("Don't know what to do with \"" ^ x ^ "\""))) - (List.rev !files); - if not !just_comp then - let bdir = - if Filename.check_suffix !out_file ".gwb" then !out_file - else !out_file ^ ".gwb" - in - if not !force && Sys.file_exists bdir then - begin - Printf.printf "The database \"%s\" already exists. \ - Use option -f to overwrite it." - !out_file; - flush stdout; - exit 2 - end; - Lock.control (Mutil.lock_file !out_file) false - ~onerror:Lock.print_error_and_exit - (fun () -> - let bdir = - if Filename.check_suffix !out_file ".gwb" then !out_file - else !out_file ^ ".gwb" - in - let next_family_fun = next_family_fun_templ (List.rev !gwo) in - if Db2link.link next_family_fun bdir then () - else - begin - Printf.eprintf "*** database not created\n"; - flush stderr; - exit 2 - end) - -let print_exc = - function - Failure txt -> Printf.printf "Failed: %s\n" txt; flush stdout; exit 2 - | exc -> Printexc.print raise exc - -let _ = try main () with exc -> print_exc exc diff --git a/bin/distrib/mk_consang/mk_consang.ml b/bin/distrib/mk_consang/mk_consang.ml index 98f8be4b89..cbf7fe9d9e 100644 --- a/bin/distrib/mk_consang/mk_consang.ml +++ b/bin/distrib/mk_consang/mk_consang.ml @@ -24,408 +24,28 @@ let anonfun s = if !fname = "" then fname := s else raise (Arg.Bad "Cannot treat several databases") -let rebuild_field_array len pad bdir compress f = - if !(Mutil.verbose) then - begin - Printf.eprintf "rebuilding %s..." (Filename.basename bdir); - flush stderr - end; - if compress then Db2out.output_value_array_compress bdir "" len pad f - else Db2out.output_value_array_no_compress bdir "" len pad f; - if !(Mutil.verbose) then begin Printf.eprintf "\n"; flush stderr end - type ('index, 'item) field_info = { fi_nb : int; fi_ht : ('index, 'item) Hashtbl.t; fi_index_of_int : int -> 'index; fi_dir : string } -let rebuild_any_field_array db2 fi pad compress (f2, get) = - let f1 = fi.fi_dir in - let bdir = - List.fold_left Filename.concat db2.Db2disk.bdir2 ["new_d"; f1; f2] - in - Mutil.mkdir_p bdir; - rebuild_field_array fi.fi_nb pad bdir compress - (fun oc_acc output_item -> - (* put pad as 1st elem; not necessary, just for beauty *) - if compress then ignore (output_item pad : int); - for i = 0 to fi.fi_nb - 1 do - let x = - try get (Hashtbl.find fi.fi_ht (fi.fi_index_of_int i)) with - Not_found -> - let pos = Db2disk.get_field_acc db2 i (f1, f2) in - Db2disk.get_field_data db2 pos (f1, f2) "data" - in - let pos = output_item x in output_binary_int oc_acc pos - done) - -let rebuild_option_field_array db2 fi pad (f2, get) = - let f1 = fi.fi_dir in - let bdir = - List.fold_left Filename.concat db2.Db2disk.bdir2 ["new_d"; f1; f2] - in - Mutil.mkdir_p bdir; - rebuild_field_array fi.fi_nb pad bdir true - (fun oc_acc output_item -> - for i = 0 to fi.fi_nb - 1 do - let x = - try get (Hashtbl.find fi.fi_ht (fi.fi_index_of_int i)) with - Not_found -> - let pos = Db2disk.get_field_acc db2 i (f1, f2) in - if pos = -1 then None - else Some (Db2disk.get_field_data db2 pos (f1, f2) "data") - in - match x with - None -> output_binary_int oc_acc (-1) - | Some x -> let pos = output_item x in output_binary_int oc_acc pos - done) - -let rebuild_list_field_array db2 fi (f2, get) = - let f1 = fi.fi_dir in - let f oc_acc oc_dat = - for i = 0 to fi.fi_nb - 1 do - let x = - try get (Hashtbl.find fi.fi_ht (fi.fi_index_of_int i)) with - Not_found -> - let pos = Db2disk.get_field_acc db2 i (f1, f2) in - if pos = -1 then [] - else Db2disk.get_field_data db2 pos (f1, f2) "data" - in - if x = [] then output_binary_int oc_acc (-1) - else - let pos = pos_out oc_dat in - Iovalue.output oc_dat x; output_binary_int oc_acc pos - done - in - let bdir = - List.fold_left Filename.concat db2.Db2disk.bdir2 ["new_d"; f1; f2] - in - Mutil.mkdir_p bdir; - if !(Mutil.verbose) then - begin - Printf.eprintf "rebuilding %s..." (Filename.basename bdir); - flush stderr - end; - let oc_dat = open_out_bin (Filename.concat bdir "data") in - let oc_acc = open_out_bin (Filename.concat bdir "access") in - f oc_acc oc_dat; - close_out oc_acc; - close_out oc_dat; - if !(Mutil.verbose) then begin Printf.eprintf "\n"; flush stderr end - -let rebuild_list2_field_array db2 fi (f2, get) = - let f1 = fi.fi_dir in - let f oc_acc oc_dat = - for i = 0 to fi.fi_nb - 1 do - let rxl = - try get (Hashtbl.find fi.fi_ht (fi.fi_index_of_int i)) with - Not_found -> - let pos = Db2disk.get_field_acc db2 i (f1, f2) in - let rec loop list pos = - if pos = -1 then list - else - let (x, pos) = - Db2disk.get_field_2_data db2 pos (f1, f2) "data" - in - loop (x :: list) pos - in - loop [] pos - in - let pos = - let rec loop pos = - function - [] -> pos - | x :: xl -> - let new_pos = pos_out oc_dat in - Iovalue.output oc_dat x; - Iovalue.output oc_dat pos; - loop new_pos xl - in - loop (-1) rxl - in - output_binary_int oc_acc pos - done - in - let bdir = - List.fold_left Filename.concat db2.Db2disk.bdir2 ["new_d"; f1; f2] - in - Mutil.mkdir_p bdir; - if !(Mutil.verbose) then - begin - Printf.eprintf "rebuilding %s..." (Filename.basename bdir); - flush stderr - end; - let oc_dat = open_out_bin (Filename.concat bdir "data") in - let oc_acc = open_out_bin (Filename.concat bdir "access") in - f oc_acc oc_dat; - close_out oc_acc; - close_out oc_dat; - if !(Mutil.verbose) then begin Printf.eprintf "\n"; flush stderr end - -let rebuild_string_field db2 fi (f2, get) = - let f1 = fi.fi_dir in - let bdir = - List.fold_left Filename.concat db2.Db2disk.bdir2 ["new_d"; f1; f2] - in - Mutil.mkdir_p bdir; - rebuild_field_array fi.fi_nb "" bdir true - (fun oc_acc output_item -> - for i = 0 to fi.fi_nb - 1 do - let s = - try get (Hashtbl.find fi.fi_ht (fi.fi_index_of_int i)) with - Not_found -> - let pos = Db2disk.get_field_acc db2 i (f1, f2) in - Db2disk.string_of_istr2 db2 (f1, f2) pos - in - let pos = output_item s in output_binary_int oc_acc pos - done) - -let rebuild_list_with_string_field_array g h db2 fi (f2, get) = - let f1 = fi.fi_dir in - let bdir = - List.fold_left Filename.concat db2.Db2disk.bdir2 ["new_d"; f1; f2] - in - Mutil.mkdir_p bdir; - let oc_ext = open_out_bin (Filename.concat bdir "data2.ext") in - rebuild_field_array fi.fi_nb "" bdir true - (fun oc_acc output_item -> - for i = 0 to fi.fi_nb - 1 do - let sl = - try get (Hashtbl.find fi.fi_ht (fi.fi_index_of_int i)) with - Not_found -> - let list : 'a list = - let pos = Db2disk.get_field_acc db2 i (f1, f2) in - if pos = -1 then [] - else Db2disk.get_field_data db2 pos (f1, f2) "data2.ext" - in - List.map (g (Db2disk.string_of_istr2 db2 (f1, f2))) list - in - let pl = List.map (h output_item) sl in - if pl = [] then output_binary_int oc_acc (-1) - else - begin - output_binary_int oc_acc (pos_out oc_ext); - let (s32, s64) = !(Iovalue.size_32), !(Iovalue.size_64) in - Iovalue.output oc_ext (pl : 'a list); - Iovalue.size_32 := s32; - Iovalue.size_64 := s64 - end - done); - close_out oc_ext - -let unique_key_string (ht, scnt) s = - let s = Name.lower (Mutil.nominative s) in - try Hashtbl.find ht s with - Not_found -> - let istr = Adef.istr_of_int !scnt in - Hashtbl.add ht s istr; incr scnt; istr - -let make_key_index db2 nb_per bdir = - if !(Mutil.verbose) then begin Printf.eprintf "key index..."; flush stderr end; - let person_of_key_d = Filename.concat bdir "person_of_key" in - (try Mutil.mkdir_p person_of_key_d with _ -> ()); - let ht_index_of_key = Hashtbl.create 1 in - let ht_strings = Hashtbl.create 1, ref 0 in - let f1f2_fn = Filename.concat "new_d" "person", "first_name" in - let f1f2_sn = Filename.concat "new_d" "person", "surname" in - let f1f2_oc = Filename.concat "new_d" "person", "occ" in - for i = 0 to nb_per - 1 do - let fn = - let pos = Db2disk.get_field_acc db2 i f1f2_fn in - Db2disk.string_of_istr2 db2 f1f2_fn pos - in - assert (Obj.tag (Obj.repr fn) = Obj.string_tag); - let sn = - let pos = Db2disk.get_field_acc db2 i f1f2_sn in - Db2disk.string_of_istr2 db2 f1f2_sn pos - in - assert (Obj.tag (Obj.repr sn) = Obj.string_tag); - if fn = "?" || sn = "?" then () - else - let fn = unique_key_string ht_strings fn in - let sn = unique_key_string ht_strings sn in - let oc = Db2disk.get_field db2 i f1f2_oc in - Hashtbl.add ht_index_of_key (Db2.key2_of_key (fn, sn, oc)) - (Adef.iper_of_int i) - done; - Db2out.output_hashtbl person_of_key_d "iper_of_key.ht" - (ht_index_of_key : (Db2.key2, Def.iper) Hashtbl.t); - Hashtbl.clear ht_index_of_key; - Db2out.output_hashtbl person_of_key_d "istr_of_string.ht" - (fst ht_strings : (string, Adef.istr) Hashtbl.t); - Hashtbl.clear (fst ht_strings); - if !(Mutil.verbose) then begin Printf.eprintf "\n"; flush stderr end - -let rebuild_fields2 db2 = - let fi_per = - {fi_nb = db2.Db2disk.patches.Db2disk.nb_per; - fi_ht = db2.Db2disk.patches.Db2disk.h_person; - fi_index_of_int = Adef.iper_of_int; fi_dir = "person"} - in - let fi_asc = - {fi_nb = db2.Db2disk.patches.Db2disk.nb_per; - fi_ht = db2.Db2disk.patches.Db2disk.h_ascend; - fi_index_of_int = Adef.iper_of_int; fi_dir = "person"} - in - let fi_uni = - {fi_nb = db2.Db2disk.patches.Db2disk.nb_per; - fi_ht = db2.Db2disk.patches.Db2disk.h_union; - fi_index_of_int = Adef.iper_of_int; fi_dir = "person"} - in - List.iter (rebuild_string_field db2 fi_per) - ["first_name", (fun p -> p.Def.first_name); - "surname", (fun p -> p.Def.surname); "image", (fun p -> p.Def.image); - "public_name", (fun p -> p.Def.public_name); - "occupation", (fun p -> p.Def.occupation); - "birth_place", (fun p -> p.Def.birth_place); - "birth_note", (fun p -> p.Def.birth_note); - "birth_src", (fun p -> p.Def.birth_src); - "baptism_place", (fun p -> p.Def.baptism_place); - "baptism_note", (fun p -> p.Def.baptism_note); - "baptism_src", (fun p -> p.Def.baptism_src); - "death_place", (fun p -> p.Def.death_place); - "death_note", (fun p -> p.Def.death_note); - "death_src", (fun p -> p.Def.death_src); - "burial_place", (fun p -> p.Def.burial_place); - "burial_note", (fun p -> p.Def.burial_note); - "burial_src", (fun p -> p.Def.burial_src); - "notes", (fun p -> p.Def.notes); "psources", (fun p -> p.Def.psources)]; - rebuild_any_field_array db2 fi_per 0 true ("occ", (fun p -> p.Def.occ)); - List.iter - (rebuild_list_with_string_field_array (fun f -> f) (fun f -> f) db2 - fi_per) - ["qualifiers", (fun p -> p.Def.qualifiers); - "aliases", (fun p -> p.Def.aliases); - "first_names_aliases", (fun p -> p.Def.first_names_aliases); - "surnames_aliases", (fun p -> p.Def.surnames_aliases)]; - rebuild_list_with_string_field_array Futil.map_title_strings - Futil.map_title_strings db2 fi_per ("titles", (fun p -> p.Def.titles)); - rebuild_list_field_array db2 fi_per ("rparents", (fun p -> p.Def.rparents)); - rebuild_list2_field_array db2 fi_per ("related", (fun p -> p.Def.related)); - rebuild_any_field_array db2 fi_per Def.Neuter true - ("sex", (fun p -> p.Def.sex)); - rebuild_any_field_array db2 fi_per Def.IfTitles true - ("access", (fun p -> p.Def.access)); - List.iter (rebuild_any_field_array db2 fi_per Adef.cdate_None true) - ["birth", (fun p -> p.Def.birth); "baptism", (fun p -> p.Def.baptism)]; - rebuild_any_field_array db2 fi_per Def.NotDead true - ("death", (fun p -> p.Def.death)); - rebuild_any_field_array db2 fi_per Def.UnknownBurial true - ("burial", (fun p -> p.Def.burial)); - rebuild_list_field_array db2 fi_per ("pevents", (fun p -> p.Def.pevents)); - rebuild_option_field_array db2 fi_asc (Adef.ifam_of_int (-1)) - ("parents", (fun p -> p.Def.parents)); - rebuild_any_field_array db2 fi_asc Adef.no_consang false - ("consang", (fun p -> p.Def.consang)); - rebuild_any_field_array db2 fi_uni [| |] false - ("family", (fun p -> p.Def.family)); - let fi_fam = - {fi_nb = db2.Db2disk.patches.Db2disk.nb_fam; - fi_ht = db2.Db2disk.patches.Db2disk.h_family; - fi_index_of_int = Adef.ifam_of_int; fi_dir = "family"} - in - let fi_cpl = - {fi_nb = db2.Db2disk.patches.Db2disk.nb_fam; - fi_ht = db2.Db2disk.patches.Db2disk.h_couple; - fi_index_of_int = Adef.ifam_of_int; fi_dir = "family"} - in - let fi_des = - {fi_nb = db2.Db2disk.patches.Db2disk.nb_fam; - fi_ht = db2.Db2disk.patches.Db2disk.h_descend; - fi_index_of_int = Adef.ifam_of_int; fi_dir = "family"} - in - rebuild_any_field_array db2 fi_fam Adef.cdate_None true - ("marriage", (fun f -> f.Def.marriage)); - List.iter (rebuild_string_field db2 fi_fam) - ["marriage_place", (fun f -> f.Def.marriage_place); - "marriage_note", (fun f -> f.Def.marriage_note); - "marriage_src", (fun f -> f.Def.marriage_src); - "comment", (fun f -> f.Def.comment); - "origin_file", (fun f -> f.Def.origin_file); - "fsources", (fun f -> f.Def.fsources)]; - rebuild_any_field_array db2 fi_fam [| |] true - ("witnesses", (fun f -> f.Def.witnesses)); - rebuild_any_field_array db2 fi_fam Def.Married true - ("relation", (fun f -> f.Def.relation)); - rebuild_any_field_array db2 fi_fam Def.NotDivorced true - ("divorce", (fun f -> f.Def.divorce)); - rebuild_list_field_array db2 fi_fam ("fevents", (fun f -> f.Def.fevents)); - List.iter (rebuild_any_field_array db2 fi_cpl (Adef.iper_of_int (-1)) true) - ["father", (fun f -> Adef.father f); "mother", (fun f -> Adef.mother f)]; - rebuild_any_field_array db2 fi_des [| |] false - ("children", (fun f -> f.Def.children)); - let nb_per = fi_per.fi_nb in - let new_d = Filename.concat db2.Db2disk.bdir2 "new_d" in - make_key_index db2 nb_per new_d; - Gc.compact (); - let particles = - Mutil.input_particles (Filename.concat db2.Db2disk.bdir2 "particles.txt") - in - Db2out.make_indexes new_d nb_per particles; - let old_d = Filename.concat db2.Db2disk.bdir2 "old_d" in - Mutil.remove_dir old_d; - Mutil.mkdir_p old_d; - List.iter - (fun f -> - Sys.rename (Filename.concat db2.Db2disk.bdir2 f) - (Filename.concat old_d f)) - ["family"; "person"; "person_of_key"; "person_of_name"; "patches"]; - List.iter - (fun f -> - Sys.rename (Filename.concat new_d f) - (Filename.concat db2.Db2disk.bdir2 f)) - ["family"; "person"; "person_of_key"; "person_of_name"] - +#ifdef GWDB1 let simple_output bname base carray = match carray with - Some tab -> - Gwdb.apply_base2 base - (fun db2 -> - let bdir = db2.Db2disk.bdir2 in - let dir = - List.fold_left Filename.concat bdir ["person"; "consang"] - in - Mutil.mkdir_p dir; - let oc = open_out_bin (Filename.concat dir "data") in - output_value oc tab; - close_out oc; - let oc = open_out_bin (Filename.concat dir "access") in - let _ = - (Iovalue.output_array_access oc (Array.get tab) - (Array.length tab) 0 : - int) - in - close_out oc; - let has_patches = - Sys.file_exists (Filename.concat bdir "patches") - in - if has_patches then - let list = - Hashtbl.fold - (fun ip a list -> - let a = - {a with Def.consang = tab.(Adef.int_of_iper ip)} - in - (ip, a) :: list) - db2.Db2disk.patches.Db2disk.h_ascend [] - in - List.iter - (fun (ip, a) -> - Hashtbl.replace db2.Db2disk.patches.Db2disk.h_ascend ip a) - list; - Db2disk.commit_patches2 db2; - rebuild_fields2 db2) + | Some _tab -> assert false | None -> - Gwdb.apply_base1 base - (fun base -> - let bname = base.Dbdisk.data.Dbdisk.bdir in - let no_patches = - not (Sys.file_exists (Filename.concat bname "patches")) - in - Outbase.gen_output (no_patches && not !indexes) bname base); - (* On recalcul le nombre reel de personnes. *) - Util.init_cache_info bname base + Gwdb1.apply_base1 base + (fun base -> + let bname = base.Dbdisk.data.Dbdisk.bdir in + let no_patches = + not (Sys.file_exists (Filename.concat bname "patches")) + in + Outbase.gen_output (no_patches && not !indexes) bname base); + (* On recalcul le nombre reel de personnes. *) + Util.init_cache_info bname (Gwdb1.ToGwdb.base base) +#endif + let main () = Argl.parse speclist anonfun errmsg; @@ -455,7 +75,7 @@ let main () = try Sys.catch_break true; let carray = ConsangAll.compute ~verbosity:!verbosity base !tlim !scratch in - simple_output !fname base carray + simple_output !fname (Gwdb1.OfGwdb.base base) carray with Consang.TopologicalSortError p -> Printf.printf "\nError: loop in database, %s is his/her own ancestor.\n" (Gutil.designation base p); diff --git a/bin/distrib/setup/setup.camlp5.ml b/bin/distrib/setup/setup.camlp5.ml index 897cb671ae..e4db8a4086 100644 --- a/bin/distrib/setup/setup.camlp5.ml +++ b/bin/distrib/setup/setup.camlp5.ml @@ -874,39 +874,6 @@ let simple conf = else if not (good_name out_file) then print_file conf "err_name.htm" else print_file conf "bso.htm" -let simple2 conf = - let ged = - match p_getenv conf.env "anon" with - Some f -> strip_spaces f - | None -> "" - in - let ged = - if Filename.check_suffix (String.lowercase_ascii ged) ".ged" then ged - else "" - in - let out_file = - match p_getenv conf.env "o" with - Some f -> strip_spaces f - | _ -> "" - in - let out_file = - if ged = "" then out_file - else if out_file = "" then out_name_of_ged ged - else out_file - in - let env = ("f", "on") :: conf.env in - let env = list_replace "anon" ged env in - let conf = - {comm = if ged = "" then "gwc2" else "ged2gwb2"; - env = list_replace "o" out_file env; lang = conf.lang; - request = conf.request; lexicon = conf.lexicon} - in - if ged <> "" && not (Sys.file_exists ged) then - print_file conf "err_unkn.htm" - else if out_file = "" then print_file conf "err_miss.htm" - else if not (good_name out_file) then print_file conf "err_name.htm" - else print_file conf "bso.htm" - let gwc_or_ged2gwb out_name_of_in_name conf = let fname = match p_getenv conf.env "fname" with @@ -941,56 +908,14 @@ let gwc_or_ged2gwb out_name_of_in_name conf = else if not (good_name out_file) then print_file conf "err_name.htm" else print_file conf "bso.htm" -let gwc2_or_ged2gwb2 out_name_of_in_name conf = - let fname = - match p_getenv conf.env "fname" with - | Some f -> strip_spaces f - | None -> "" - in - let in_file = - match p_getenv conf.env "anon" with - Some f -> strip_spaces f - | None -> "" - in - let in_file = - if fname = "" then in_file - else in_file ^ (if Sys.unix then "/" else "\\") ^ fname - in - let conf = conf_with_env conf "anon" in_file in - let out_file = - match p_getenv conf.env "o" with - Some f -> strip_spaces f - | _ -> "" - in - let out_file = - if out_file = "" then out_name_of_in_name in_file else out_file - in - (* clean up env *) - let conf = conf_with_env conf "body_prop" "" in - let conf = conf_with_env conf "fname" "" in - let conf = conf_with_env conf "o" out_file in - if in_file = "" || out_file = "" then print_file conf "err_miss.htm" - else if not (Sys.file_exists in_file) && not (String.contains fname '*') - then print_file conf "err_unkn.htm" - else if not (good_name out_file) then print_file conf "err_name.htm" - else print_file conf "bso.htm" - let gwc_check conf = let conf = {conf with env = ("nofail", "on") :: ("f", "on") :: conf.env} in gwc_or_ged2gwb out_name_of_gw conf -let gwc2_check conf = - let conf = {conf with env = ("nofail", "on") :: ("f", "on") :: conf.env} in - gwc2_or_ged2gwb2 out_name_of_gw conf - let ged2gwb_check conf = let conf = {conf with env = ("f", "on") :: conf.env} in gwc_or_ged2gwb out_name_of_ged conf -let ged2gwb2_check conf = - let conf = {conf with env = ("f", "on") :: conf.env} in - gwc2_or_ged2gwb2 out_name_of_ged conf - (*ifdef WINDOWS then*) let infer_rc conf rc = if rc > 0 then rc @@ -1012,19 +937,6 @@ let gwc conf = if rc > 1 then print_file conf "bso_err.htm" else begin print_default_gwf_file conf; print_file conf "bso_ok.htm" end -let gwc2 conf = - let rc = - let comm = stringify (Filename.concat !bin_dir "gwc2") in - exec_f (comm ^ parameters conf.env) - in - let rc = if Sys.unix then rc else infer_rc conf rc in - let gwo = strip_spaces (s_getenv conf.env "anon") ^ "o" in - (try Sys.remove gwo with Sys_error _ -> ()); - Printf.eprintf "\n"; - flush stderr; - if rc > 1 then print_file conf "bso_err.htm" - else begin print_default_gwf_file conf; print_file conf "bso_ok.htm" end - let gwdiff_check conf = print_file conf "bsi_diff.htm" @@ -1338,7 +1250,7 @@ let cleanup_1 conf = Printf.eprintf "$ rmdir old\\%s\n" in_base_dir end; flush stderr; - Mutil.rm_rf (Filename.concat "old" in_base_dir); + Util.rm_rf (Filename.concat "old" in_base_dir); if Sys.unix then Printf.eprintf "$ mv %s old/.\n" in_base_dir else Printf.eprintf "$ move %s old\\.\n" in_base_dir; flush stderr; @@ -1398,7 +1310,7 @@ let rename conf = let delete conf = print_file conf "delete_1.htm" let delete_1 conf = - List.iter (fun (k, v) -> if v = "del" then Mutil.rm_rf (k ^ ".gwb")) conf.env; + List.iter (fun (k, v) -> if v = "del" then Util.rm_rf (k ^ ".gwb")) conf.env; print_file conf "del_ok.htm" let merge conf = @@ -1577,17 +1489,6 @@ let ged2gwb conf = if rc > 1 then print_file conf "bso_err.htm" else begin print_default_gwf_file conf; print_file conf "bso_ok.htm" end -let ged2gwb2 conf = - let rc = - let comm = stringify (Filename.concat !bin_dir conf.comm) in - exec_f (comm ^ " -fne '\"\"'" ^ parameters conf.env) - in - let rc = if Sys.unix then rc else infer_rc conf rc in - Printf.eprintf "\n"; - flush stderr; - if rc > 1 then print_file conf "bso_err.htm" - else begin print_default_gwf_file conf; print_file conf "bso_ok.htm" end - let consang conf ok_file = let rc = let comm = stringify (Filename.concat !bin_dir conf.comm) in @@ -1669,7 +1570,6 @@ let setup_comm_ok conf = function "gwsetup" -> setup_gen conf | "simple" -> simple conf - | "simple2" -> simple2 conf | "recover" -> recover conf | "recover_1" -> recover_1 conf | "recover_2" -> recover_2 conf @@ -1685,11 +1585,6 @@ let setup_comm_ok conf = Some "check" -> gwc_check conf | _ -> gwc conf end - | "gwc2" -> - begin match p_getenv conf.env "opt" with - Some "check" -> gwc2_check conf - | _ -> gwc2 conf - end | "gwu" -> begin match p_getenv conf.env "opt" with Some "check" -> gwu conf @@ -1700,11 +1595,6 @@ let setup_comm_ok conf = Some "check" -> ged2gwb_check conf | _ -> ged2gwb conf end - | "ged2gwb2" -> - begin match p_getenv conf.env "opt" with - Some "check" -> ged2gwb2_check conf - | _ -> ged2gwb2 conf - end | "gwb2ged" -> begin match p_getenv conf.env "opt" with Some "check" -> gwb2ged conf diff --git a/configure b/configure index bc338d55ea..f5375d946a 100755 --- a/configure +++ b/configure @@ -14,6 +14,8 @@ OS_TYPE= API_D= API_PKG= +GWDB_D= +GWDB_PKG= SOSA_PKG= while [[ $# -ne 0 ]]; do @@ -21,6 +23,9 @@ while [[ $# -ne 0 ]]; do --api) API_PKG="piqirun.ext redis-sync yojson curl"; API_D="-D API" ;; + --gwdb1) + GWDB_D="-D GWDB1" ; + GWDB_PKG="geneweb.gwdb1" ;; --sosa-num) SOSA_PKG="geneweb.sosa-num" ;; --sosa-zarith) @@ -31,6 +36,12 @@ while [[ $# -ne 0 ]]; do [[ $# -gt 0 ]] && shift done +if [[ $GWDB_D == "" ]] ; then + echo -e "\\x1b[33m[WARNING]\\x1b[0m GWDB is not set, using gwdb1" ; + GWDB_D="-D GWDB1" ; + GWDB_PKG="geneweb.gwdb1" ; +fi ; + if [[ $SOSA_PKG == "" ]] ; then echo -e "\\x1b[33m[WARNING]\\x1b[0m SOSA is not set, using geneweb.sosa" ; SOSA_PKG="geneweb.sosa" ; @@ -97,6 +108,8 @@ print_tools() { print_vars() { echo "API_D=${API_D}" echo "API_PKG=${API_PKG}" + echo "GWDB_D=${GWDB_D}" + echo "GWDB_PKG=${GWDB_PKG}" echo "SOSA_PKG=${SOSA_PKG}" } diff --git a/lib/consangAll.ml b/lib/consangAll.ml index e3a0ebd205..9ad4ddfc37 100644 --- a/lib/consangAll.ml +++ b/lib/consangAll.ml @@ -1,4 +1,3 @@ -(* $Id: consangAll.ml,v 5.35 2007/02/21 18:14:01 ddr Exp $ *) (* Copyright (c) 1998-2007 INRIA *) open Gwdb diff --git a/lib/def/dune b/lib/def/dune new file mode 100644 index 0000000000..34d16f814f --- /dev/null +++ b/lib/def/dune @@ -0,0 +1,5 @@ +(library + (name def) + (public_name geneweb.def) + (wrapped false) +) diff --git a/lib/dune.in b/lib/dune.in index eec9f3f944..7eabde1f59 100644 --- a/lib/dune.in +++ b/lib/dune.in @@ -4,13 +4,16 @@ (synopsis "GeneWeb library") (preprocess (action (run %{bin:cppo} %%%CPPO_D%%% -V OCAML:%{ocaml_version} %{input-file}))) (libraries unix - %%%API_PKG%%% %%%SOSA_PKG%%% + %%%API_PKG%%% str stdlib-shims camlp5 camlp5.gramlib + geneweb.gwdb + geneweb.def + geneweb.util geneweb.wserver markup) - (modules_without_implementation config dbdisk def templAst) + (modules_without_implementation config templAst) ) diff --git a/lib/gwdb/dune b/lib/gwdb/dune new file mode 100644 index 0000000000..1c75720a48 --- /dev/null +++ b/lib/gwdb/dune @@ -0,0 +1,8 @@ +(library + (name gwdb) + (public_name geneweb.gwdb) + (wrapped false) + (libraries geneweb.def) + (modules_without_implementation gwdb) + (flags (:standard -no-keep-locs)) +) diff --git a/lib/gwdb/gwdb.mli b/lib/gwdb/gwdb.mli index 31093642be..5b1fe4fb12 100644 --- a/lib/gwdb/gwdb.mli +++ b/lib/gwdb/gwdb.mli @@ -1,4 +1,3 @@ -(* $Id: gwdb.mli,v 5.102 2007-03-02 11:44:13 ddr Exp $ *) (* Copyright (c) 1998-2007 INRIA *) open Adef @@ -191,12 +190,3 @@ val p_first_name : base -> person -> string val p_surname : base -> person -> string val date_of_last_change : base -> float - -(**/**) -(** For database builders *) - -val base_of_base1 : Dbdisk.dsk_base -> base -val dsk_person_of_person : person -> Dbdisk.dsk_person - -val apply_base1 : base -> (Dbdisk.dsk_base -> unit) -> unit -val apply_base2 : base -> (Db2disk.db2 -> unit) -> unit diff --git a/lib/gwdb1/db2.ml b/lib/gwdb1/db2.ml deleted file mode 100644 index c25a2849a0..0000000000 --- a/lib/gwdb1/db2.ml +++ /dev/null @@ -1,12 +0,0 @@ -(* $Id: db2.ml,v 5.7 2012-01-20 19:02:51 ddr Exp $ *) -(* Copyright (c) 2006-2007 INRIA *) - -let first_item_pos len = - 20 + (if Sys.word_size = 64 && len >= 1 lsl (32 - 10) then 9 else 5) - -type key2 = - Key of Adef.istr * Adef.istr * int - | Key0 of Adef.istr * Adef.istr - -let key2_of_key (fn, sn, oc) = - if oc = 0 then Key0 (fn, sn) else Key (fn, sn, oc) diff --git a/lib/gwdb1/db2.mli b/lib/gwdb1/db2.mli deleted file mode 100644 index c99f611e4d..0000000000 --- a/lib/gwdb1/db2.mli +++ /dev/null @@ -1,7 +0,0 @@ -(* $Id: db2.mli,v 5.4 2012-01-20 19:02:51 ddr Exp $ *) -(* Copyright (c) 2006-2007 INRIA *) - -val first_item_pos : int -> int - -type key2 -val key2_of_key : Adef.istr * Adef.istr * int -> key2 diff --git a/lib/gwdb1/db2disk.ml b/lib/gwdb1/db2disk.ml deleted file mode 100644 index d08da636f8..0000000000 --- a/lib/gwdb1/db2disk.ml +++ /dev/null @@ -1,528 +0,0 @@ -(* $Id: db2disk.ml,v 5.27 2012-01-27 16:57:07 ddr Exp $ *) -(* Copyright (c) 2006-2007 INRIA *) - -open Def - -let magic_patch = "GwPt0002" - -type patches = - { mutable nb_per : int; - mutable nb_fam : int; - nb_per_ini : int; - nb_fam_ini : int; - h_person : (iper, (iper, string) gen_person) Hashtbl.t; - h_ascend : (iper, ifam gen_ascend) Hashtbl.t; - h_union : (iper, ifam gen_union) Hashtbl.t; - h_family : (ifam, (iper, string) gen_family) Hashtbl.t; - h_couple : (ifam, iper gen_couple) Hashtbl.t; - h_descend : (ifam, iper gen_descend) Hashtbl.t; - h_key : (string * string * int, iper option) Hashtbl.t; - h_name : (string, iper list) Hashtbl.t } - -type db2 = - { phony : unit -> unit; - bdir2 : string; - cache_chan : (string * string * string, in_channel) Hashtbl.t; - patches : patches; - mutable parents_array : ifam option array option; - mutable consang_array : Adef.fix array option; - mutable family_array : ifam array array option; - mutable father_array : iper array option; - mutable mother_array : iper array option; - mutable children_array : iper array array option } - -(* reading in files style database 2 *) - -let fast_open_in_bin_and_seek db2 f1 f2 f pos = - let ic = - try Hashtbl.find db2.cache_chan (f1, f2, f) with - Not_found -> - let ic = - open_in_bin (List.fold_left Filename.concat db2.bdir2 [f1; f2; f]) - in - Hashtbl.add db2.cache_chan (f1, f2, f) ic; ic - in - seek_in ic pos; ic - -let field_exists db2 (f1, f2) = - let fname = List.fold_left Filename.concat db2.bdir2 [f1; f2; "access"] in - Sys.file_exists fname - -let get_field_acc db2 i (f1, f2) = - try - let ic = fast_open_in_bin_and_seek db2 f1 f2 "access" (4 * i) in - let r = input_binary_int ic in - assert (r >= -1); assert (r <= 0x3fffffff); r - with e -> - Printf.eprintf "Error get_field_acc \"%s/%s/access\" i = %d\n" f1 f2 i; - flush stderr; - raise e - -let get_field_data db2 pos (f1, f2) data = - let ic = fast_open_in_bin_and_seek db2 f1 f2 data pos in Iovalue.input ic - -let get_field_2_data db2 pos (f1, f2) data = - let ic = fast_open_in_bin_and_seek db2 f1 f2 data pos in - let r = Iovalue.input ic in let s = Iovalue.input ic in r, s - -let get_field db2 i path = - let pos = get_field_acc db2 i path in get_field_data db2 pos path "data" - -let string_of_istr2 db2 f pos = - if pos = -1 then "" else get_field_data db2 pos f "data" - -(* hash tables in disk *) -[@@@ocaml.warning "-37"] -type ('a, 'b) bucketlist = - Empty - | Cons of 'a * 'b * ('a, 'b) bucketlist -[@@@ocaml.warning "+37"] - -let rec hashtbl_find_rec key = - function - Empty -> raise Not_found - | Cons (k, d, rest) -> - if compare key k = 0 then d else hashtbl_find_rec key rest - -let hashtbl_find dir file key = - let ic_ht = open_in_bin (Filename.concat dir file) in - let ic_hta = open_in_bin (Filename.concat dir (file ^ "a")) in - let alen = input_binary_int ic_hta in - let pos = Mutil.int_size + Hashtbl.hash key mod alen * Mutil.int_size in - seek_in ic_hta pos; - let pos = input_binary_int ic_hta in - close_in ic_hta; - seek_in ic_ht pos; - let bl : (_, _) bucketlist = Iovalue.input ic_ht in - close_in ic_ht; hashtbl_find_rec key bl - -let hashtbl_find_all dir file key = - let rec find_in_bucket = - function - Empty -> [] - | Cons (k, d, rest) -> - if compare k key = 0 then d :: find_in_bucket rest - else find_in_bucket rest - in - try - let ic_ht = open_in_bin (Filename.concat dir file) in - let ic_hta = open_in_bin (Filename.concat dir (file ^ "a")) in - let alen = input_binary_int ic_hta in - let pos = Mutil.int_size + Hashtbl.hash key mod alen * Mutil.int_size in - seek_in ic_hta pos; - let pos = input_binary_int ic_hta in - close_in ic_hta; - seek_in ic_ht pos; - let bl : (_, _) bucketlist = Iovalue.input ic_ht in - close_in ic_ht; find_in_bucket bl - with Sys_error _ -> [] - -let key_hashtbl_find dir file k = hashtbl_find dir file (Db2.key2_of_key k) - -(* string person index version 2 *) - -type string_person_index2 = - { is_first_name : bool; - index_of_first_char : (string * int) list; - mutable ini : string; - mutable curr_i : int; - mutable curr_s : string } - -let start_with s p = - String.length p <= String.length s && String.sub s 0 (String.length p) = p - -type string_person = - Sp of int - | SpNew of string - -let sorted_patched_person_strings db2 is_first_name = - let particles = - Mutil.input_particles (Filename.concat db2.bdir2 "particles.txt") - in - let sl = - Hashtbl.fold - (fun _ip p sl -> - let s = if is_first_name then p.first_name else p.surname in s :: sl) - db2.patches.h_person [] - in - let sl = List.sort_uniq compare sl in - let sl = - List.map - (fun s -> - let s_ord = - try - let part = List.find (start_with s) particles in - let plen = String.length part in - String.sub s plen (String.length s - plen) ^ " (" ^ part ^ ")" - with Not_found -> s - in - s_ord, s) - sl - in - List.sort compare sl - -let spi2_first db2 spi (f1, f2) s = - spi.ini <- s; - let i_opt = - (* to be faster, go directly to the first string starting with - the same char *) - if s = "" then Some 0 - else - let nbc = Name.nbc s.[0] in - let rec loop = - function - (s1, i1) :: list -> - if s1 = "" then loop list - else - let nbc1 = Name.nbc s1.[0] in - if nbc = nbc1 && nbc > 0 && nbc <= String.length s && - nbc <= String.length s1 && - String.sub s 0 nbc = String.sub s1 0 nbc - then - Some i1 - else loop list - | [] -> None - in - loop spi.index_of_first_char - in - let first_in_disk = - match i_opt with - Some i -> - let ic = fast_open_in_bin_and_seek db2 f1 f2 "index.acc" (4 * i) in - let pos = input_binary_int ic in - let ic = fast_open_in_bin_and_seek db2 f1 f2 "index.dat" pos in - begin try - let rec loop i = - let (s1, pos) = (Iovalue.input ic : string * int) in - if start_with s1 s then Some (s1, pos, i) else loop (i + 1) - in - loop i - with End_of_file -> None - end - | None -> None - in - let first_patched = - let patched_sl = sorted_patched_person_strings db2 spi.is_first_name in - let rec loop = - function - (s2_ord, s2) :: sl -> - if s2_ord < s then loop sl - else if start_with s2_ord s then Some (s2_ord, s2) - else loop sl - | [] -> None - in - loop patched_sl - in - match first_in_disk, first_patched with - Some (s1, _, _), Some (s2_ord, s2) when s2_ord < s1 -> - spi.curr_s <- s2_ord; SpNew s2 - | Some (s1, pos, i), _ -> spi.curr_i <- i; spi.curr_s <- s1; Sp pos - | None, Some (s2_ord, s2) -> spi.curr_s <- s2_ord; SpNew s2 - | None, None -> raise Not_found - -let spi2_next db2 spi (f1, f2) need_whole_list = - let i_opt = - if spi.ini = "" && not need_whole_list then - let rec loop = - function - (_, i1) :: ((_, i2) :: _ as list) -> - if spi.curr_i = i1 then Some i2 else loop list - | [] | [_] -> None - in - loop spi.index_of_first_char - else Some (spi.curr_i + 1) - in - let next_in_disk = - match i_opt with - Some i -> - begin try - let ic = - let ic = - fast_open_in_bin_and_seek db2 f1 f2 "index.acc" (i * 4) - in - let pos = input_binary_int ic in - fast_open_in_bin_and_seek db2 f1 f2 "index.dat" pos - in - let (s, pos) = (Iovalue.input ic : string * int) in - let dlen = i - spi.curr_i in Some (i, s, pos, dlen) - with End_of_file -> None - end - | None -> None - in - let next_patched = - let patched_sl = sorted_patched_person_strings db2 spi.is_first_name in - let rec loop = - function - (s2_ord, s2) :: sl -> - if s2_ord <= spi.curr_s then loop sl else Some (s2_ord, s2) - | [] -> None - in - loop patched_sl - in - match next_in_disk, next_patched with - Some (_, s1, _, _), Some (s2_ord, s2) when s2_ord < s1 -> - spi.curr_s <- s2_ord; SpNew s2, 1 - | Some (i, s1, pos, dlen), _ -> - spi.curr_i <- i; spi.curr_s <- s1; Sp pos, dlen - | None, Some (s2_ord, s2) -> spi.curr_s <- s2_ord; SpNew s2, 1 - | None, None -> raise Not_found - -let spi2gen_add pl db2 spi s = - let proj = - if spi.is_first_name then fun p -> p.first_name else fun p -> p.surname - in - Hashtbl.fold - (fun _ p iperl -> if proj p = s then p.key_index :: iperl else iperl) - db2.patches.h_person pl - -let spi2_find db2 spi (f1, f2) pos = - let dir = List.fold_left Filename.concat db2.bdir2 [f1; f2] in - let pl = hashtbl_find_all dir "person_of_string.ht" pos in - let s = string_of_istr2 db2 (f1, f2) pos in spi2gen_add pl db2 spi s - -let spi2gen_find = spi2gen_add [] - -(* *) - -let disk_person2_of_key db2 fn sn oc = - let person_of_key_d = Filename.concat db2.bdir2 "person_of_key" in - try - let ifn = hashtbl_find person_of_key_d "istr_of_string.ht" fn in - let isn = hashtbl_find person_of_key_d "istr_of_string.ht" sn in - let key = ifn, isn, oc in - Some (key_hashtbl_find person_of_key_d "iper_of_key.ht" key : iper) - with Not_found -> None - -let person2_of_key db2 fn sn oc = - let fn = Name.lower (Mutil.nominative fn) in - let sn = Name.lower (Mutil.nominative sn) in - try Hashtbl.find db2.patches.h_key (fn, sn, oc) with - Not_found -> disk_person2_of_key db2 fn sn oc - -let strings2_of_fsname db2 f s = - let k = Name.crush_lower s in - let dir = List.fold_left Filename.concat db2.bdir2 ["person"; f] in - hashtbl_find_all dir "string_of_crush.ht" k - -let persons2_of_name db2 s = - let s = Name.crush_lower s in - let dir = Filename.concat db2.bdir2 "person_of_name" in - List.rev_append (try Hashtbl.find db2.patches.h_name s with Not_found -> []) - (hashtbl_find_all dir "person_of_name.ht" s) - -let persons_of_first_name_or_surname2 db2 is_first_name = - let f1 = "person" in - let f2 = if is_first_name then "first_name" else "surname" in - let fdir = List.fold_left Filename.concat db2.bdir2 [f1; f2] in - let index_ini_fname = Filename.concat fdir "index.ini" in - let ic = open_in_bin index_ini_fname in - let iofc : (string * int) list = input_value ic in - close_in ic; - {is_first_name = is_first_name; index_of_first_char = iofc; ini = ""; - curr_i = 0; curr_s = ""} - -let load_array2 bdir nb_ini nb def f1 f2 get = - if nb = 0 then [| |] - else - try - let ic_acc = - open_in_bin (List.fold_left Filename.concat bdir [f1; f2; "access"]) - in - let ic_dat = - open_in_bin (List.fold_left Filename.concat bdir [f1; f2; "data"]) - in - let tab = Array.make nb def in - for i = 0 to nb_ini - 1 do - tab.(i) <- get ic_dat (input_binary_int ic_acc) - done; - close_in ic_dat; - close_in ic_acc; - tab - with e -> - Printf.eprintf "Error load_array2 %s/%s nb_ini %d nb %d\n" f1 f2 nb_ini nb; - flush stderr; - raise e - -let load_couples_array2 db2 = - Printf.eprintf "*** loading couples array\n"; - flush stderr; - let nb = db2.patches.nb_fam in - begin match db2.father_array with - Some _ -> () - | None -> - let tab = - load_array2 db2.bdir2 db2.patches.nb_fam_ini nb (Adef.iper_of_int 0) - "family" "father" - (fun ic_dat pos -> seek_in ic_dat pos; Iovalue.input ic_dat) - in - Hashtbl.iter (fun i c -> tab.(Adef.int_of_ifam i) <- Adef.father c) - db2.patches.h_couple; - db2.father_array <- Some tab - end; - match db2.mother_array with - Some _ -> () - | None -> - let tab = - load_array2 db2.bdir2 db2.patches.nb_fam_ini nb (Adef.iper_of_int 0) - "family" "mother" - (fun ic_dat pos -> seek_in ic_dat pos; Iovalue.input ic_dat) - in - Hashtbl.iter (fun i c -> tab.(Adef.int_of_ifam i) <- Adef.mother c) - db2.patches.h_couple; - db2.mother_array <- Some tab - -let parents_array2 db2 nb_ini nb = - let arr = - if nb_ini = 0 then Array.make nb None - else - load_array2 db2.bdir2 nb_ini nb None "person" "parents" - (fun ic_dat pos -> - if pos = -1 then None - else - begin seek_in ic_dat pos; Some (Iovalue.input ic_dat : ifam) end) - in - Hashtbl.iter (fun i a -> arr.(Adef.int_of_iper i) <- a.parents) - db2.patches.h_ascend; - arr - -let consang_array2 db2 nb = - let arr = - let cg_fname = - List.fold_left Filename.concat db2.bdir2 ["person"; "consang"; "data"] - in - match try Some (open_in_bin cg_fname) with Sys_error _ -> None with - Some ic -> - let tab = input_value ic in - close_in ic; - if Array.length tab < db2.patches.nb_per_ini then - failwith - (Printf.sprintf "consang_array2 array length = %d < %d" - (Array.length tab) db2.patches.nb_per_ini); - if nb > Array.length tab then - Array.append tab - (Array.make (nb - Array.length tab) Adef.no_consang) - else tab - | None -> Array.make nb Adef.no_consang - in - Hashtbl.iter (fun i a -> arr.(Adef.int_of_iper i) <- a.consang) - db2.patches.h_ascend; - arr - -let family_array2 db2 = - let fname = - List.fold_left Filename.concat db2.bdir2 ["person"; "family"; "data"] - in - let ic = open_in_bin fname in - let tab = input_value ic in - close_in ic; - if Array.length tab < db2.patches.nb_per_ini then - failwith - (Printf.sprintf "family_array2 array length = %d < %d" (Array.length tab) - db2.patches.nb_per_ini); - tab - -let children_array2 db2 = - let fname = - List.fold_left Filename.concat db2.bdir2 ["family"; "children"; "data"] - in - let ic = open_in_bin fname in - let tab = input_value ic in - close_in ic; - if Array.length tab < db2.patches.nb_fam_ini then - failwith - (Printf.sprintf "children_array2 array length = %d < %d" (Array.length tab) - db2.patches.nb_fam_ini); - tab - -let read_notes db2 fnotes rn_mode = - let bdir = db2.bdir2 in - let fname = - if fnotes = "" then "notes.txt" - else Filename.concat "notes_d" (fnotes ^ ".txt") - in - match - try Some (Secure.open_in (Filename.concat bdir fname)) with - Sys_error _ -> None - with - Some ic -> - let str = - match rn_mode with - RnDeg -> if in_channel_length ic = 0 then "" else " " - | Rn1Ln -> (try input_line ic with End_of_file -> "") - | RnAll -> - let rec loop len = - match try Some (input_char ic) with End_of_file -> None with - Some c -> loop (Buff.store len c) - | _ -> Buff.get len - in - loop 0 - in - close_in ic; str - | None -> "" - -let check_magic ic magic id = - let b = really_input_string ic (String.length magic) in - if b <> magic then failwith (Printf.sprintf "bad %s magic number" id) - -let commit_patches2 db2 = - let fname = Filename.concat db2.bdir2 "patches" in - let oc = open_out_bin (fname ^ "1") in - output_string oc magic_patch; - Mutil.output_value_no_sharing oc db2.patches; - close_out oc; - Mutil.remove_file (fname ^ "~"); - (try Sys.rename fname (fname ^ "~") with Sys_error _ -> ()); - Sys.rename (fname ^ "1") fname - -let commit_notes2 db2 fnotes s = - let bdir = db2.bdir2 in - if fnotes <> "" then - (try Unix.mkdir (Filename.concat bdir "notes_d") 0o755 with _ -> ()); - let fname = - if fnotes = "" then "notes.txt" - else Filename.concat "notes_d" (fnotes ^ ".txt") - in - let fname = Filename.concat bdir fname in - (try Sys.remove (fname ^ "~") with Sys_error _ -> ()); - (try Sys.rename fname (fname ^ "~") with _ -> ()); - if s = "" then () - else let oc = Secure.open_out fname in output_string oc s; close_out oc - -let base_of_base2 bname = - let bname = - if Filename.check_suffix bname ".gwb" then bname else bname ^ ".gwb" - in - let bdir = Filename.concat bname "base_d" in - let patches = - let patch_fname = Filename.concat bdir "patches" in - match try Some (open_in_bin patch_fname) with Sys_error _ -> None with - Some ic -> - check_magic ic magic_patch "patch"; - let p = input_value ic in close_in ic; flush stderr; p - | None -> - let nb_per = - let fname = - List.fold_left Filename.concat bdir ["person"; "sex"; "access"] - in - let st = Unix.lstat fname in st.Unix.st_size / 4 - in - let nb_fam = - let fname = - List.fold_left Filename.concat bdir - ["family"; "marriage"; "access"] - in - let st = Unix.lstat fname in st.Unix.st_size / 4 - in - let empty_ht () = Hashtbl.create 1 in - {nb_per = nb_per; nb_fam = nb_fam; nb_per_ini = nb_per; - nb_fam_ini = nb_fam; h_person = empty_ht (); h_ascend = empty_ht (); - h_union = empty_ht (); h_family = empty_ht (); - h_couple = empty_ht (); h_descend = empty_ht (); h_key = empty_ht (); - h_name = empty_ht ()} - in - {bdir2 = bdir; cache_chan = Hashtbl.create 1; patches = patches; - parents_array = None; consang_array = None; family_array = None; - father_array = None; mother_array = None; children_array = None; - phony = fun () -> ()} - -let iter_patched_keys db2 f = Hashtbl.iter f db2.patches.h_key diff --git a/lib/gwdb1/db2disk.mli b/lib/gwdb1/db2disk.mli deleted file mode 100644 index 017c3c406c..0000000000 --- a/lib/gwdb1/db2disk.mli +++ /dev/null @@ -1,78 +0,0 @@ -(* $Id: db2disk.mli,v 5.10 2007-03-03 05:27:21 ddr Exp $ *) -(* Copyright (c) 2006-2007 INRIA *) - -open Def - -type patches = - { mutable nb_per : int; - mutable nb_fam : int; - nb_per_ini : int; - nb_fam_ini : int; - h_person : (iper, (iper, string) gen_person) Hashtbl.t; - h_ascend : (iper, ifam gen_ascend) Hashtbl.t; - h_union : (iper, ifam gen_union) Hashtbl.t; - h_family : (ifam, (iper, string) gen_family) Hashtbl.t; - h_couple : (ifam, iper gen_couple) Hashtbl.t; - h_descend : (ifam, iper gen_descend) Hashtbl.t; - h_key : (string * string * int, iper option) Hashtbl.t; - h_name : (string, iper list) Hashtbl.t } - -type db2 = - { phony : unit -> unit; - bdir2 : string; - cache_chan : (string * string * string, in_channel) Hashtbl.t; - patches : patches; - mutable parents_array : ifam option array option; - mutable consang_array : Adef.fix array option; - mutable family_array : ifam array array option; - mutable father_array : iper array option; - mutable mother_array : iper array option; - mutable children_array : iper array array option } - -type string_person = - Sp of int - | SpNew of string - -type string_person_index2 = - { is_first_name : bool; - index_of_first_char : (string * int) list; - mutable ini : string; - mutable curr_i : int; - mutable curr_s : string } - -val field_exists : db2 -> string * string -> bool -val get_field_acc : db2 -> int -> string * string -> int -val get_field_data : db2 -> int -> string * string -> string -> 'a -val get_field_2_data : db2 -> int -> string * string -> string -> 'a * 'b -val get_field : db2 -> int -> string * string -> 'a -val string_of_istr2 : db2 -> string * string -> int -> string - -val spi2_first : - db2 -> string_person_index2 -> string * string -> string -> string_person -val spi2_next : - db2 -> string_person_index2 -> string * string -> bool -> - string_person * int -val spi2_find : - db2 -> string_person_index2 -> string * string -> int -> iper list -val spi2gen_find : db2 -> string_person_index2 -> string -> iper list - -val disk_person2_of_key : db2 -> string -> string -> int -> iper option -val person2_of_key : db2 -> string -> string -> int -> iper option -val strings2_of_fsname : db2 -> string -> string -> int list -val persons2_of_name : db2 -> string -> iper list -val persons_of_first_name_or_surname2 : db2 -> bool -> string_person_index2 - -val load_couples_array2 : db2 -> unit - -val parents_array2 : db2 -> int -> int -> ifam option array -val consang_array2 : db2 -> int -> Adef.fix array -val family_array2 : db2 -> ifam array array -val children_array2 : db2 -> iper array array -val read_notes : db2 -> string -> rn_mode -> string - -val commit_patches2 : db2 -> unit -val commit_notes2 : db2 -> string -> string -> unit -val base_of_base2 : string -> db2 - -val iter_patched_keys : - db2 -> (string * string * int -> iper option -> unit) -> unit diff --git a/lib/gwdb1/db2out.ml b/lib/gwdb1/db2out.ml deleted file mode 100644 index 7fd0c38324..0000000000 --- a/lib/gwdb1/db2out.ml +++ /dev/null @@ -1,442 +0,0 @@ -(* $Id: db2out.ml,v 5.28 2012-01-27 17:14:03 ddr Exp $ *) -(* Copyright (c) 2007 INRIA *) - -let phony_min_size = 8 - -let check_input_value _func _fname _len = () - (* Printf.eprintf "*** check input_value (%s) %s\n" func fname; flush stderr; - * let ic = open_in_bin fname in - * let tab = input_value ic in - * if not (Obj.is_block (Obj.repr tab)) then failwith "not a block" else (); - * Printf.eprintf "tab len %d cnt %d\n" (Array.length tab) len; - * flush stderr; - * if Array.length tab <> len then failwith "error" else (); - * close_in ic; - * Printf.eprintf "check ok\n"; flush stderr *) - -let output_item_no_compress_return_pos oc_dat item_cnt s = - incr item_cnt ; let pos = pos_out oc_dat in Iovalue.output oc_dat s; pos - -let output_value_array_no_compress bdir e len pad f = - let oc_acc = open_out_bin (Filename.concat bdir ("access" ^ e)) in - let oc_dat = open_out_bin (Filename.concat bdir ("data" ^ e)) in - let header_pos = Iovalue.create_output_value_header oc_dat in - Iovalue.output_block_header oc_dat 0 (max len phony_min_size); - assert (pos_out oc_dat = Db2.first_item_pos len); - let nb_items = ref 0 in - f oc_acc (output_item_no_compress_return_pos oc_dat nb_items); - (* padding to at least 8 items to allow correct read by input_value *) - for i = !nb_items + 1 to 8 do - incr nb_items; - Iovalue.output oc_dat (pad : 'a) - done; - assert (Db2.first_item_pos !nb_items = Db2.first_item_pos len); - let _ = (Iovalue.patch_output_value_header oc_dat header_pos : int) in - close_out oc_dat; - close_out oc_acc; - (* test *) - check_input_value "Db2out.output_value_array_no_compress" - (Filename.concat bdir ("data" ^ e)) (max len phony_min_size) - -let output_item_compress_return_pos oc_dat ht item_cnt s = - try Hashtbl.find ht s with - Not_found -> - incr item_cnt; - let pos = pos_out oc_dat in - Iovalue.output oc_dat s; Hashtbl.add ht s pos; pos - -let output_value_array_compress bdir e _ pad f = - let oc_acc = open_out_bin (Filename.concat bdir ("access" ^ e)) in - let oc_dat = open_out_bin (Filename.concat bdir ("data" ^ e)) in - let ht : ('a, _) Hashtbl.t = Hashtbl.create 1 in - let header_pos = Iovalue.create_output_value_header oc_dat in - let len = phony_min_size in - Iovalue.output_block_header oc_dat 0 len; - assert (pos_out oc_dat = Db2.first_item_pos len); - let nb_items = ref 0 in - f oc_acc (output_item_compress_return_pos oc_dat ht nb_items); - (* padding to at least 8 items to allow correct read by input_value *) - for i = !nb_items + 1 to 8 do - incr nb_items; - Iovalue.output oc_dat (pad : 'a) - done; - if Db2.first_item_pos !nb_items = Db2.first_item_pos len then - begin - Iovalue.size_32 := !(Iovalue.size_32) - len + !nb_items; - Iovalue.size_64 := !(Iovalue.size_64) - len + !nb_items; - let _ = (Iovalue.patch_output_value_header oc_dat header_pos : int) in - Iovalue.output_block_header oc_dat 0 !nb_items; - assert (pos_out oc_dat = Db2.first_item_pos !nb_items); - close_out oc_dat; - close_out oc_acc; - (* test *) - let fname = Filename.concat bdir ("data" ^ e) in - check_input_value "Db2out.output_value_array_compress" fname !nb_items - end - else if Db2.first_item_pos !nb_items > Db2.first_item_pos len then - begin - (* may happen one day and to be debugged then *) - Printf.eprintf "nb_items %d\n" !nb_items; - Printf.eprintf "first_item_pos nb_items %d\n" - (Db2.first_item_pos !nb_items); - flush stderr; - Printf.eprintf "rebuilding it..."; - flush stderr; - close_out oc_dat; - close_out oc_acc; - let fname = Filename.concat bdir ("data" ^ e) in - let ic = open_in_bin fname in - let oc = open_out_bin (fname ^ "2") in - let header_pos = Iovalue.create_output_value_header oc in - Iovalue.output_block_header oc 0 !nb_items; - seek_in ic (Db2.first_item_pos len); - begin try while true do output_byte oc (input_byte ic) done with - End_of_file -> () - end; - let _ = (Iovalue.patch_output_value_header oc header_pos : int) in - close_out oc; - close_in ic; - Mutil.remove_file fname; - Sys.rename (fname ^ "2") fname; - Printf.eprintf " ok"; - flush stderr; - (* test *) - check_input_value "Db2out.output_value_array_compress 1" fname !nb_items - end - else assert false - -[@@@ocaml.warning "-37"] -type ('a, 'b) hashtbl_t = - { mutable size : int; - mutable data : ('a, 'b) bucketlist array; - mutable seed : int; - initial_size : int } -and ('a, 'b) bucketlist = - Empty - | Cons of 'a * 'b * ('a, 'b) bucketlist -[@@@ocaml.warning "+37"] - -let output_hashtbl dir file ht = - let oc_ht = open_out_bin (Filename.concat dir file) in - let oc_hta = open_out_bin (Filename.concat dir (file ^ "a")) in - let ht : ('a, 'b) hashtbl_t = Obj.magic (ht : ('a, 'b) Hashtbl.t) in - (* check compatibility with version of Hashtbl of OCaml *) - assert (Obj.is_block (Obj.repr ht)); - assert (Obj.tag (Obj.repr ht) = 0); - assert (Obj.size (Obj.repr ht) >= 2 && Obj.size (Obj.repr ht) <= 4); - assert (Obj.is_int (Obj.repr ht.size)); - assert (Obj.is_block (Obj.repr ht.data)); - if Obj.size (Obj.repr ht) >= 3 then assert (Obj.is_int (Obj.repr ht.seed)); - if Obj.size (Obj.repr ht) >= 4 then - assert (Obj.is_int (Obj.repr ht.initial_size)); - output_binary_int oc_hta (Array.length ht.data); - let pos_start = Iovalue.create_output_value_header oc_ht in - Iovalue.output_block_header oc_ht 0 (Obj.size (Obj.repr ht)); - Iovalue.output oc_ht ht.size; - Iovalue.output_block_header oc_ht 0 (Array.length ht.data); - for i = 0 to Array.length ht.data - 1 do - assert - (Obj.is_int (Obj.repr ht.data.(i)) && Obj.magic ht.data.(i) = 0 || - Obj.is_block (Obj.repr ht.data.(i)) && - Obj.tag (Obj.repr ht.data.(i)) = 0 && - Obj.size (Obj.repr ht.data.(i)) = 3); - output_binary_int oc_hta (pos_out oc_ht); - Iovalue.output oc_ht ht.data.(i) - done; - if Obj.size (Obj.repr ht) >= 3 then Iovalue.output oc_ht ht.seed; - if Obj.size (Obj.repr ht) >= 4 then Iovalue.output oc_ht ht.initial_size; - let _ = (Iovalue.patch_output_value_header oc_ht pos_start : int) in - close_out oc_hta; close_out oc_ht - -let add_name ht s pos = - let k = Name.crush_lower s in - let posl = Hashtbl.find_all ht k in - if List.mem pos posl then () else Hashtbl.add ht k pos - -let make_string_of_crush_index bpdir = - List.iter - (fun (field, is_surname) -> - let field_d = Filename.concat bpdir field in - let pos_1st = - let ic_acc = open_in_bin (Filename.concat field_d "access") in - let pos = try input_binary_int ic_acc with End_of_file -> -1 in - close_in ic_acc; pos - in - if !(Mutil.verbose) then - begin Printf.eprintf "string_of_crush %s..." field; flush stderr end; - let ht = Hashtbl.create 1 in - if pos_1st >= 0 then - begin let ic_dat = open_in_bin (Filename.concat field_d "data") in - seek_in ic_dat pos_1st; - begin let rec loop pos = - match - try Some (Iovalue.input ic_dat) with End_of_file -> None - with - Some s -> - assert (Obj.tag (Obj.repr s) = Obj.string_tag); - if s <> "?" then - begin - add_name ht s pos; - if is_surname then - List.iter (fun s -> add_name ht s pos) - (Mutil.surnames_pieces s) - end; - loop (pos_in ic_dat) - | None -> () - in - loop pos_1st - end; - close_in ic_dat - end; - output_hashtbl field_d "string_of_crush.ht" ht; - if !(Mutil.verbose) then begin Printf.eprintf "\n"; flush stderr end) - ["first_name", false; "surname", true] - -let make_person_of_string_index bpdir = - List.iter - (fun field -> - let field_d = Filename.concat bpdir field in - let ic_acc = open_in_bin (Filename.concat field_d "access") in - if !(Mutil.verbose) then - begin - Printf.eprintf "person_of_string %s..." field; - flush stderr - end; - let ht = Hashtbl.create 1 in - begin let rec loop i = - match - try Some (input_binary_int ic_acc) with End_of_file -> None - with - Some pos -> Hashtbl.add ht pos i; loop (i + 1) - | None -> () - in - loop 0 - end; - close_in ic_acc; - output_hashtbl field_d "person_of_string.ht" ht; - if !(Mutil.verbose) then begin Printf.eprintf "\n"; flush stderr end) - ["first_name"; "surname"] - -let read_field (ic_acc, ic_dat) i = - seek_in ic_acc (4 * i); - let pos = input_binary_int ic_acc in - seek_in ic_dat pos; Iovalue.input ic_dat - -let read_string_field : _ -> _ -> string = read_field -let read_array_int_field : _ -> _ -> int array = read_field -let read_int_field : _ -> _ -> int = read_field - -let read_string_list_field (ic_acc, ic_dat, ic_str) i = - seek_in ic_acc (4 * i); - let pos = input_binary_int ic_acc in - if pos = -1 then [] - else - begin - seek_in ic_dat pos; - let posl : int list = Iovalue.input ic_dat in - List.map - (fun pos -> seek_in ic_str pos; (Iovalue.input ic_str : string)) posl - end - -let read_title_list_field (ic_acc, ic_dat, ic_str) i = - seek_in ic_acc (4 * i); - let pos = input_binary_int ic_acc in - if pos = -1 then [] - else - begin - seek_in ic_dat pos; - let tl : int Def.gen_title list = Iovalue.input ic_dat in - List.map - (Futil.map_title_strings - (fun pos -> seek_in ic_str pos; (Iovalue.input ic_str : string))) - tl - end - -let make_name_index base_d nbper = - if !(Mutil.verbose) then - begin Printf.eprintf "name index...\n"; flush stderr end; - let ic2_list = - List.map - (fun (d, f) -> - let d = List.fold_left Filename.concat base_d [d; f] in - let fn_acc = Filename.concat d "access" in - let fn_dat = Filename.concat d "data" in - let ic_acc = open_in_bin fn_acc in - let ic_dat = open_in_bin fn_dat in f, (ic_acc, ic_dat)) - ["person", "first_name"; "person", "surname"; "person", "public_name"; - "person", "sex"; "person", "family"; "family", "father"; - "person", "parents"] - in - let ic3_list = - List.map - (fun f -> - let d = List.fold_left Filename.concat base_d ["person"; f] in - let fn_acc = Filename.concat d "access" in - let ic_acc = open_in_bin fn_acc in - let fn_dat = Filename.concat d "data2.ext" in - let ic_dat = open_in_bin fn_dat in - let fn_str = Filename.concat d "data" in - let ic_str = open_in_bin fn_str in f, (ic_acc, ic_dat, ic_str)) - ["qualifiers"; "aliases"; "first_names_aliases"; "surnames_aliases"; - "titles"] - in - let get_first_name = read_string_field (List.assoc "first_name" ic2_list) in - let get_surname = read_string_field (List.assoc "surname" ic2_list) in - let get_public_name = - read_string_field (List.assoc "public_name" ic2_list) - in - let get_qualifiers = - read_string_list_field (List.assoc "qualifiers" ic3_list) - in - let get_aliases = read_string_list_field (List.assoc "aliases" ic3_list) in - let get_first_names_aliases = - read_string_list_field (List.assoc "first_names_aliases" ic3_list) - in - let get_surnames_aliases = - read_string_list_field (List.assoc "surnames_aliases" ic3_list) - in - let get_titles = read_title_list_field (List.assoc "titles" ic3_list) in - let get_family = read_array_int_field (List.assoc "family" ic2_list) in - let get_father = read_int_field (List.assoc "father" ic2_list) in - let get_husbands = - let (ic_acc, ic_dat) = List.assoc "sex" ic2_list in - fun i -> - seek_in ic_acc (4 * i); - let pos = input_binary_int ic_acc in - seek_in ic_dat pos; - let sex : Def.sex = Iovalue.input ic_dat in - if sex = Def.Female then - List.map - (fun ifam -> - let husb = get_father ifam in - let husb_surname = get_surname husb in - let husb_surn_ali = get_surnames_aliases husb in - husb_surname, husb_surn_ali) - (Array.to_list (get_family i)) - else [] - in - let get_parents = - let (ic_acc, ic_dat) = List.assoc "parents" ic2_list in - fun i -> - seek_in ic_acc (4 * i); - let pos = input_binary_int ic_acc in - if pos = -1 then None - else begin seek_in ic_dat pos; Some (Iovalue.input ic_dat) end - in - let get_father_titles_places i = - match get_parents i with - Some ifam -> - let ifath = get_father ifam in - List.map (fun t -> t.Def.t_place) (get_titles ifath) - | None -> [] - in - let ht = Hashtbl.create 1 in - if nbper > 0 && !(Mutil.verbose) then ProgrBar.start (); - for i = 0 to nbper - 1 do - if !(Mutil.verbose) then ProgrBar.run i nbper; - let first_name = get_first_name i in - let surname = get_surname i in - let names = - let names = - Futil.gen_person_misc_names first_name surname (get_public_name i) - (get_qualifiers i) (get_aliases i) (get_first_names_aliases i) - (get_surnames_aliases i) (get_titles i) (get_husbands i) - (get_father_titles_places i) - in - Name.lower (first_name ^ " " ^ surname) :: names - in - List.iter (fun s -> Hashtbl.add ht (Name.crush_lower s) i) names - done; - if nbper > 0 && !(Mutil.verbose) then ProgrBar.finish (); - List.iter (fun (_, (ic_acc, ic_dat)) -> close_in ic_acc; close_in ic_dat) - ic2_list; - List.iter - (fun (_, (ic_acc, ic_dat, ic_str)) -> - close_in ic_acc; close_in ic_dat; close_in ic_str) - ic3_list; - let dir = Filename.concat base_d "person_of_name" in - Mutil.mkdir_p dir; output_hashtbl dir "person_of_name.ht" ht - -let start_with s p = - String.length p < String.length s && String.sub s 0 (String.length p) = p - -let make_index bdir particles f2 = - let f1 = "person" in - let fdir = List.fold_left Filename.concat bdir [f1; f2] in - let index_dat_fname = Filename.concat fdir "index.dat" in - let index_ini_fname = Filename.concat fdir "index.ini" in - let pos_1st = - let ic_acc = open_in_bin (Filename.concat fdir "access") in - let pos = try input_binary_int ic_acc with End_of_file -> -1 in - close_in ic_acc; pos - in - let (list, len) = - if pos_1st >= 0 then - let data_fname = Filename.concat fdir "data" in - let ic = open_in_bin data_fname in - seek_in ic pos_1st; - let rec loop list len pos = - match - try Some (Iovalue.input ic : string) with End_of_file -> None - with - Some s -> - assert (Obj.tag (Obj.repr s) = Obj.string_tag); - let s = - try - let part = List.find (start_with s) particles in - let plen = String.length part in - String.sub s plen (String.length s - plen) ^ " (" ^ part ^ ")" - with Not_found -> s - in - let list = (s, pos) :: list in loop list (len + 1) (pos_in ic) - | None -> let _ = close_in ic in list, len - in - loop [] 0 pos_1st - else [], 0 - in - let list = List.sort compare list in - let a = Array.make len ("", 0) in - let iofc = - let rec loop rev_iofc i = - function - [] -> List.rev rev_iofc - | (s, _ as s_pos) :: list -> - a.(i) <- s_pos; - let rev_iofc = - match rev_iofc with - (prev_s, _) :: _ -> - if s = "" && i <> 0 then rev_iofc - else if prev_s = "" then (s, i) :: rev_iofc - else - let prev_nbc = Name.nbc prev_s.[0] in - let nbc = Name.nbc s.[0] in - if prev_nbc = nbc && nbc > 0 && - nbc <= String.length prev_s && nbc <= String.length s && - String.sub prev_s 0 nbc = String.sub s 0 nbc - then - rev_iofc - else (s, i) :: rev_iofc - | [] -> [s, i] - in - loop rev_iofc (i + 1) list - in - loop [] 0 list - in - let oc = open_out_bin index_dat_fname in - output_value oc (a : (string * int) array); - close_out oc; - let oc = open_out_bin (Filename.concat fdir "index.acc") in - let _ = - (Iovalue.output_array_access oc (Array.get a) (Array.length a) 0 : int) - in - close_out oc; - let oc = open_out_bin index_ini_fname in - output_value oc (iofc : (string * int) list); close_out oc - -let make_indexes bbdir nb_per particles = - let bpdir = Filename.concat bbdir "person" in - make_string_of_crush_index bpdir; - make_person_of_string_index bpdir; - make_name_index bbdir nb_per; - make_index bbdir particles "first_name"; - make_index bbdir particles "surname" diff --git a/lib/gwdb1/db2out.mli b/lib/gwdb1/db2out.mli deleted file mode 100644 index 0bdafaaa6e..0000000000 --- a/lib/gwdb1/db2out.mli +++ /dev/null @@ -1,21 +0,0 @@ -(* $Id: db2out.mli,v 5.12 2012-01-21 10:30:52 ddr Exp $ *) -(* Copyright (c) 2007 INRIA *) - -val phony_min_size : int - -val output_item_compress_return_pos : - out_channel -> ('a, int) Hashtbl.t -> int ref -> 'a -> int - -val output_value_array_no_compress : - string -> string -> int -> 'a -> (out_channel -> ('a -> int) -> unit) -> - unit - -val output_value_array_compress : - string -> string -> int -> 'a -> (out_channel -> ('a -> int) -> unit) -> - unit - -val output_hashtbl : string -> string -> (_, _) Hashtbl.t -> unit - -val make_indexes : string -> int -> string list -> unit - -val check_input_value : string -> string -> int -> unit diff --git a/lib/gwdb1/dune b/lib/gwdb1/dune index 16b1fa3cb0..79d557b6af 100644 --- a/lib/gwdb1/dune +++ b/lib/gwdb1/dune @@ -1,7 +1,10 @@ (library - (name gwdb) - (public_name geneweb.gwdb) + (name gwdb1) + (public_name geneweb.gwdb1) (wrapped false) (libraries geneweb.def geneweb.wserver geneweb.util geneweb.io) (modules_without_implementation dbdisk) + (flags (:standard -no-keep-locs)) ) + +(rule (copy# %{lib:geneweb.gwdb:gwdb.mli} gwdb.mli)) diff --git a/lib/gwdb1/gwdb.ml b/lib/gwdb1/gwdb.ml index 3ca19bb05e..f6dec74d32 100644 --- a/lib/gwdb1/gwdb.ml +++ b/lib/gwdb1/gwdb.ml @@ -1,1492 +1 @@ -(* $Id: gwdb.ml,v 5.244 2012-01-18 20:49:57 ddr Exp $ *) -(* Copyright (c) 1998-2007 INRIA *) - -open Dbdisk -open Db2disk -open Def - -type 'istr gen_string_person_index = - 'istr Dbdisk.string_person_index = - { find : 'istr -> iper list; - cursor : string -> 'istr; - next : 'istr -> 'istr } - -let milazy_force f a (get, set) p = - match get p with - Some v -> v - | None -> let v = f a in set p (Some v); v - -let ht_find ht i = Hashtbl.find_opt ht i - -let no_person empty_string ip = - {first_name = empty_string; surname = empty_string; occ = 0; - image = empty_string; first_names_aliases = []; surnames_aliases = []; - public_name = empty_string; qualifiers = []; titles = []; rparents = []; - related = []; aliases = []; occupation = empty_string; sex = Neuter; - access = Private; birth = Adef.cdate_None; birth_place = empty_string; - birth_note = empty_string; birth_src = empty_string; - baptism = Adef.cdate_None; baptism_place = empty_string; - baptism_note = empty_string; baptism_src = empty_string; - death = DontKnowIfDead; death_place = empty_string; - death_note = empty_string; death_src = empty_string; - burial = UnknownBurial; burial_place = empty_string; - burial_note = empty_string; burial_src = empty_string; pevents = []; - notes = empty_string; psources = empty_string; key_index = ip} -let no_ascend = {parents = None; consang = Adef.no_consang} -let no_union = {family = [| |]} - -(* Strings - common definitions *) - -type istr = - Istr of dsk_istr - | Istr2 of db2 * (string * string) * int - | Istr2New of db2 * string - -type 'a istr_fun = - { is_empty_string : 'a -> bool; - is_quest_string : 'a -> bool; - un_istr : 'a -> Adef.istr; - un_istr2 : 'a -> string } - -type relation = (iper, istr) Def.gen_relation -type title = istr Def.gen_title -type pers_event = (iper, istr) Def.gen_pers_event -type fam_event = (iper, istr) Def.gen_fam_event - -let eq_istr i1 i2 = - match i1, i2 with - Istr i1, Istr i2 -> Adef.int_of_istr i1 = Adef.int_of_istr i2 - | Istr2 (_, (f11, f12), i1), Istr2 (_, (f21, f22), i2) -> - i1 = i2 && f11 = f21 && f12 = f22 - | Istr2New (_, s1), Istr2New (_, s2) -> s1 = s2 - | Istr2 (db2, f, pos), Istr2New (_, s2) -> string_of_istr2 db2 f pos = s2 - | Istr2New (_, s1), Istr2 (db2, f, pos) -> s1 = string_of_istr2 db2 f pos - | _ -> failwith "eq_istr" - -(* Strings - implementation database 1 *) - -let istr1_fun = - {is_empty_string = (fun istr -> Adef.int_of_istr istr = 0); - is_quest_string = (fun istr -> Adef.int_of_istr istr = 1); - un_istr = (fun i -> i); un_istr2 = fun _i -> failwith "un_istr2 1"} - -(* Strings - implementation database 2 *) - -let istr2_fun = - {is_empty_string = - (fun (db2, path, pos) -> string_of_istr2 db2 path pos = ""); - is_quest_string = - (fun (db2, path, pos) -> string_of_istr2 db2 path pos = "?"); - un_istr = (fun _ -> failwith "un_istr"); - un_istr2 = fun (db2, path, pos) -> string_of_istr2 db2 path pos} - -let istr2new_fun = - {is_empty_string = (fun (_db2, s) -> s = ""); - is_quest_string = (fun (_db2, s) -> s = "?"); - un_istr = (fun (_db2, _s) -> failwith "un_istr"); - un_istr2 = fun (_db2, s) -> s} - -(* Strings - user functions *) - -let wrap_istr f g h = - function - Istr istr -> f istr1_fun istr - | Istr2 (db2, path, pos) -> g istr2_fun (db2, path, pos) - | Istr2New (db2, s) -> h istr2new_fun (db2, s) - -let is_empty_string i = let f pf = pf.is_empty_string in wrap_istr f f f i -let is_quest_string i = let f pf = pf.is_quest_string in wrap_istr f f f i -let un_istr i = let f pf = pf.un_istr in wrap_istr f f f i -let un_istr2 i = let f pf = pf.un_istr2 in wrap_istr f f f i - -(* String person index - common definitions *) - -type string_person_index = - Spi of dsk_istr gen_string_person_index - | Spi2 of db2 * string_person_index2 - -type 'a spi = - { spi_first : 'a -> string -> istr; - spi_next : 'a -> istr -> bool -> istr * int; - spi_find : 'a -> istr -> iper list } - -(* String person index - implementation database 1 *) - -let spi1_fun = - {spi_first = (fun spi s -> Istr (spi.cursor s)); - spi_next = - (fun spi istr _need_whole_list -> - match istr with - Istr s -> Istr (spi.next s), 1 - | _ -> failwith "not impl spi_next"); - spi_find = - fun spi s -> - match s with - Istr s -> spi.find s - | _ -> failwith "not impl spi_find"} - -(* String person index - implementation database 2 *) - -let spi2_fun = - {spi_first = - (fun (db2, spi) s -> - let f1 = "person" in - let f2 = if spi.is_first_name then "first_name" else "surname" in - match spi2_first db2 spi (f1, f2) s with - Sp pos -> Istr2 (db2, (f1, f2), pos) - | SpNew s2 -> Istr2New (db2, s2)); - spi_next = - (fun (db2, spi) _istr need_whole_list -> - let f1 = "person" in - let f2 = if spi.is_first_name then "first_name" else "surname" in - let (sp, dlen) = spi2_next db2 spi (f1, f2) need_whole_list in - let r = - match sp with - Sp pos -> Istr2 (db2, (f1, f2), pos) - | SpNew s2 -> Istr2New (db2, s2) - in - r, dlen); - spi_find = - fun (_db2, spi) s -> - match s with - Istr2 (db2, (f1, f2), pos) -> spi2_find db2 spi (f1, f2) pos - | Istr2New (db2, s) -> spi2gen_find db2 spi s - | _ -> failwith "not impl spi_find"} - -(* String person index - user functions *) - -let wrap_spi f g = - function - Spi spi -> f spi1_fun spi - | Spi2 (db2, spi2) -> g spi2_fun (db2, spi2) - -let spi_find = let f pf = pf.spi_find in wrap_spi f f -let spi_first = let f pf = pf.spi_first in wrap_spi f f -let spi_next = let f pf = pf.spi_next in wrap_spi f f - -(* Persons - common definitions *) - -type person = - Person of dsk_base * int * person1_dat - | Person2 of db2 * int * person2_dat -and person1_dat = - { mutable per1 : dsk_person option; - mutable asc1 : dsk_ascend option; - mutable uni1 : dsk_union option } -and person2_dat = - { mutable per2 : (iper, string) gen_person option option; - mutable asc2 : ifam gen_ascend option option; - mutable uni2 : ifam gen_union option option } - -type ('p, 'a, 'u) person_fun = - { get_access : 'p -> access; - get_aliases : 'p -> istr list; - get_baptism : 'p -> cdate; - get_baptism_place : 'p -> istr; - get_baptism_note : 'p -> istr; - get_baptism_src : 'p -> istr; - get_birth : 'p -> cdate; - get_birth_place : 'p -> istr; - get_birth_note : 'p -> istr; - get_birth_src : 'p -> istr; - get_burial : 'p -> Def.burial; - get_burial_place : 'p -> istr; - get_burial_note : 'p -> istr; - get_burial_src : 'p -> istr; - get_death : 'p -> Def.death; - get_death_place : 'p -> istr; - get_death_note : 'p -> istr; - get_death_src : 'p -> istr; - get_first_name : 'p -> istr; - get_first_names_aliases : 'p -> istr list; - get_image : 'p -> istr; - get_key_index : 'p -> iper; - get_notes : 'p -> istr; - get_occ : 'p -> int; - get_occupation : 'p -> istr; - get_psources : 'p -> istr; - get_public_name : 'p -> istr; - get_qualifiers : 'p -> istr list; - get_related : 'p -> iper list; - get_rparents : 'p -> relation list; - get_sex : 'p -> Def.sex; - get_surname : 'p -> istr; - get_surnames_aliases : 'p -> istr list; - get_titles : 'p -> title list; - get_pevents : 'p -> pers_event list; - gen_person_of_person : 'p -> (iper, istr) Def.gen_person; - dsk_person_of_person : 'p -> Dbdisk.dsk_person; - get_consang : 'a -> Adef.fix; - get_parents : 'a -> ifam option; - get_family : 'u -> ifam array } - -(* Persons - implementation database 1 *) - -let person1_fun = - {get_access = (fun p -> p.Def.access); - get_aliases = (fun p -> List.map (fun i -> Istr i) p.Def.aliases); - get_baptism = (fun p -> p.Def.baptism); - get_baptism_place = (fun p -> Istr p.Def.baptism_place); - get_baptism_note = (fun p -> Istr p.Def.baptism_note); - get_baptism_src = (fun p -> Istr p.Def.baptism_src); - get_birth = (fun p -> p.Def.birth); - get_birth_place = (fun p -> Istr p.Def.birth_place); - get_birth_note = (fun p -> Istr p.Def.birth_note); - get_birth_src = (fun p -> Istr p.Def.birth_src); - get_burial = (fun p -> p.Def.burial); - get_burial_place = (fun p -> Istr p.Def.burial_place); - get_burial_note = (fun p -> Istr p.Def.burial_note); - get_burial_src = (fun p -> Istr p.Def.burial_src); - get_death = (fun p -> p.Def.death); - get_death_place = (fun p -> Istr p.Def.death_place); - get_death_note = (fun p -> Istr p.Def.death_note); - get_death_src = (fun p -> Istr p.Def.death_src); - get_first_name = (fun p -> Istr p.Def.first_name); - get_first_names_aliases = - (fun p -> List.map (fun i -> Istr i) p.Def.first_names_aliases); - get_image = (fun p -> Istr p.Def.image); - get_key_index = (fun p -> p.Def.key_index); - get_notes = (fun p -> Istr p.Def.notes); get_occ = (fun p -> p.Def.occ); - get_occupation = (fun p -> Istr p.Def.occupation); - get_psources = (fun p -> Istr p.Def.psources); - get_public_name = (fun p -> Istr p.Def.public_name); - get_qualifiers = (fun p -> List.map (fun i -> Istr i) p.Def.qualifiers); - get_related = (fun p -> p.Def.related); - get_rparents = - (fun p -> - List.map (Futil.map_relation_ps (fun x -> x) (fun i -> Istr i)) - p.Def.rparents); - get_sex = (fun p -> p.Def.sex); - get_surname = (fun p -> Istr p.Def.surname); - get_surnames_aliases = - (fun p -> List.map (fun i -> Istr i) p.Def.surnames_aliases); - get_titles = - (fun p -> - List.map (fun t -> Futil.map_title_strings (fun i -> Istr i) t) - p.Def.titles); - get_pevents = - (fun p -> - List.map (fun t -> Futil.map_pers_event (fun x -> x) (fun i -> Istr i) t) - p.Def.pevents); - gen_person_of_person = - (fun p -> Futil.map_person_ps (fun p -> p) (fun s -> Istr s) p); - dsk_person_of_person = (fun p -> p); - get_consang = (fun a -> a.Def.consang); - get_parents = (fun a -> a.Def.parents); get_family = fun u -> u.Def.family} - -(* Persons - implementation database 2 *) - -let make_istr2 db2 path i = Istr2 (db2, path, get_field_acc db2 i path) - -let get_list_field db2 i f1f2 = - let pos = get_field_acc db2 i f1f2 in - if pos = -1 then [] else get_field_data db2 pos f1f2 "data2.ext" - -let person2_fun = - let rec self = - {get_access = (fun (db2, i) -> get_field db2 i ("person", "access")); - get_aliases = - (fun (db2, i) -> - let list = get_list_field db2 i ("person", "aliases") in - List.map (fun pos -> Istr2 (db2, ("person", "aliases"), pos)) list); - get_baptism = (fun (db2, i) -> get_field db2 i ("person", "baptism")); - get_baptism_place = - (fun (db2, i) -> make_istr2 db2 ("person", "baptism_place") i); - get_baptism_note = - (fun (db2, i) -> make_istr2 db2 ("person", "baptism_note") i); - get_baptism_src = - (fun (db2, i) -> make_istr2 db2 ("person", "baptism_src") i); - get_birth = (fun (db2, i) -> get_field db2 i ("person", "birth")); - get_birth_place = - (fun (db2, i) -> make_istr2 db2 ("person", "birth_place") i); - get_birth_note = - (fun (db2, i) -> make_istr2 db2 ("person", "birth_note") i); - get_birth_src = - (fun (db2, i) -> make_istr2 db2 ("person", "birth_src") i); - get_burial = (fun (db2, i) -> get_field db2 i ("person", "burial")); - get_burial_place = - (fun (db2, i) -> make_istr2 db2 ("person", "burial_place") i); - get_burial_note = - (fun (db2, i) -> make_istr2 db2 ("person", "burial_note") i); - get_burial_src = - (fun (db2, i) -> make_istr2 db2 ("person", "burial_src") i); - get_death = (fun (db2, i) -> get_field db2 i ("person", "death")); - get_death_place = - (fun (db2, i) -> make_istr2 db2 ("person", "death_place") i); - get_death_note = - (fun (db2, i) -> make_istr2 db2 ("person", "death_note") i); - get_death_src = - (fun (db2, i) -> make_istr2 db2 ("person", "death_src") i); - get_first_name = - (fun (db2, i) -> make_istr2 db2 ("person", "first_name") i); - get_first_names_aliases = - (fun (db2, i) -> - let list = get_list_field db2 i ("person", "first_names_aliases") in - List.map - (fun pos -> Istr2 (db2, ("person", "first_names_aliases"), pos)) - list); - get_image = (fun (db2, i) -> make_istr2 db2 ("person", "image") i); - get_key_index = (fun (_db2, i) -> Adef.iper_of_int i); - get_notes = (fun (db2, i) -> make_istr2 db2 ("person", "notes") i); - get_occ = (fun (db2, i) -> get_field db2 i ("person", "occ")); - get_occupation = - (fun (db2, i) -> make_istr2 db2 ("person", "occupation") i); - get_psources = (fun (db2, i) -> make_istr2 db2 ("person", "psources") i); - get_public_name = - (fun (db2, i) -> make_istr2 db2 ("person", "public_name") i); - get_qualifiers = - (fun (db2, i) -> - let list = get_list_field db2 i ("person", "qualifiers") in - List.map (fun pos -> Istr2 (db2, ("person", "qualifiers"), pos)) - list); - get_related = - (fun (db2, i) -> - let pos = get_field_acc db2 i ("person", "related") in - let rec loop list pos = - if pos = -1 then List.rev list - else - let (ip, pos) = - get_field_2_data db2 pos ("person", "related") "data" - in - loop (ip :: list) pos - in - loop [] pos); - get_rparents = - (fun (db2, i) -> - let pos = get_field_acc db2 i ("person", "rparents") in - if pos = -1 then [] - else - let rl = get_field_data db2 pos ("person", "rparents") "data" in - List.map - (Futil.map_relation_ps (fun x -> x) - (fun _ -> Istr2 (db2, ("", ""), -1))) - rl); - get_sex = (fun (db2, i) -> get_field db2 i ("person", "sex")); - get_surname = (fun (db2, i) -> make_istr2 db2 ("person", "surname") i); - get_surnames_aliases = - (fun (db2, i) -> - let list = get_list_field db2 i ("person", "surnames_aliases") in - List.map - (fun pos -> Istr2 (db2, ("person", "surnames_aliases"), pos)) - list); - get_titles = - (fun (db2, i) -> - let list = get_list_field db2 i ("person", "titles") in - List.map - (Futil.map_title_strings - (fun pos -> Istr2 (db2, ("person", "titles"), pos))) - list); - get_pevents = - (fun (db2, i) -> - let list = get_list_field db2 i ("person", "pevents") in - List.map - (Futil.map_pers_event (fun x -> x) - (fun pos -> Istr2 (db2, ("person", "pevents"), pos))) - list); - gen_person_of_person = - (fun pp -> - {first_name = self.get_first_name pp; surname = self.get_surname pp; - occ = self.get_occ pp; image = self.get_image pp; - public_name = self.get_public_name pp; - qualifiers = self.get_qualifiers pp; aliases = self.get_aliases pp; - first_names_aliases = self.get_first_names_aliases pp; - surnames_aliases = self.get_surnames_aliases pp; - titles = self.get_titles pp; rparents = self.get_rparents pp; - related = self.get_related pp; occupation = self.get_occupation pp; - sex = self.get_sex pp; access = self.get_access pp; - birth = self.get_birth pp; birth_place = self.get_birth_place pp; - birth_note = self.get_birth_note pp; - birth_src = self.get_birth_src pp; baptism = self.get_baptism pp; - baptism_place = self.get_baptism_place pp; - baptism_note = self.get_baptism_note pp; - baptism_src = self.get_baptism_src pp; death = self.get_death pp; - death_place = self.get_death_place pp; - death_note = self.get_death_note pp; - death_src = self.get_death_src pp; burial = self.get_burial pp; - burial_place = self.get_burial_place pp; - burial_note = self.get_burial_note pp; - burial_src = self.get_burial_src pp; pevents = self.get_pevents pp; - notes = self.get_notes pp; psources = self.get_psources pp; - key_index = self.get_key_index pp}); - dsk_person_of_person = - (fun _p -> failwith "not impl dsk_person_of_person"); - get_consang = - (fun (db2, i) -> - match db2.consang_array with - Some tab -> tab.(i) - | None -> - let f = "person", "consang" in - if field_exists db2 f then get_field db2 i f - else Adef.no_consang); - get_parents = - (fun (db2, i) -> - match db2.parents_array with - Some tab -> tab.(i) - | None -> - let pos = get_field_acc db2 i ("person", "parents") in - if pos = -1 then None - else - Some (get_field_data db2 pos ("person", "parents") "data")); - get_family = - fun (db2, i) -> - match db2.family_array with - Some tab -> tab.(i) - | None -> get_field db2 i ("person", "family")} - in - self - -let person2gen_fun = - {get_access = (fun (_db2, _i, p) -> p.Def.access); - get_aliases = - (fun (db2, _i, p) -> List.map (fun s -> Istr2New (db2, s)) p.Def.aliases); - get_baptism = (fun (_db2, _i, p) -> p.Def.baptism); - get_baptism_place = - (fun (db2, _i, p) -> Istr2New (db2, p.Def.baptism_place)); - get_baptism_note = (fun (db2, _i, p) -> Istr2New (db2, p.Def.baptism_note)); - get_baptism_src = (fun (db2, _i, p) -> Istr2New (db2, p.Def.baptism_src)); - get_birth = (fun (_db2, _i, p) -> p.Def.birth); - get_birth_place = (fun (db2, _i, p) -> Istr2New (db2, p.Def.birth_place)); - get_birth_note = (fun (db2, _i, p) -> Istr2New (db2, p.Def.birth_note)); - get_birth_src = (fun (db2, _i, p) -> Istr2New (db2, p.Def.birth_src)); - get_burial = (fun (_db2, _i, p) -> p.Def.burial); - get_burial_place = (fun (db2, _i, p) -> Istr2New (db2, p.Def.burial_place)); - get_burial_note = (fun (db2, _i, p) -> Istr2New (db2, p.Def.burial_note)); - get_burial_src = (fun (db2, _i, p) -> Istr2New (db2, p.Def.burial_src)); - get_death = (fun (_db2, _i, p) -> p.Def.death); - get_death_place = (fun (db2, _i, p) -> Istr2New (db2, p.Def.death_place)); - get_death_note = (fun (db2, _i, p) -> Istr2New (db2, p.Def.death_note)); - get_death_src = (fun (db2, _i, p) -> Istr2New (db2, p.Def.death_src)); - get_first_name = (fun (db2, _i, p) -> Istr2New (db2, p.Def.first_name)); - get_first_names_aliases = - (fun (db2, _i, p) -> - List.map (fun s -> Istr2New (db2, s)) p.Def.first_names_aliases); - get_image = (fun (db2, _i, p) -> Istr2New (db2, p.Def.image)); - get_key_index = (fun (_db2, _i, p) -> p.Def.key_index); - get_notes = (fun (db2, _i, p) -> Istr2New (db2, p.Def.notes)); - get_occ = (fun (_db2, _i, p) -> p.Def.occ); - get_occupation = (fun (db2, _i, p) -> Istr2New (db2, p.Def.occupation)); - get_psources = (fun (db2, _i, p) -> Istr2New (db2, p.Def.psources)); - get_public_name = (fun (db2, _i, p) -> Istr2New (db2, p.Def.public_name)); - get_qualifiers = - (fun (db2, _i, p) -> - List.map (fun s -> Istr2New (db2, s)) p.Def.qualifiers); - get_related = (fun (_db2, _i, p) -> p.Def.related); - get_rparents = - (fun (db2, _i, p) -> - List.map (Futil.map_relation_ps (fun x -> x) (fun s -> Istr2New (db2, s))) - p.Def.rparents); - get_sex = (fun (_db2, _i, p) -> p.Def.sex); - get_surname = (fun (db2, _i, p) -> Istr2New (db2, p.Def.surname)); - get_surnames_aliases = - (fun (db2, _i, p) -> - List.map (fun s -> Istr2New (db2, s)) p.Def.surnames_aliases); - get_titles = - (fun (db2, _i, p) -> - List.map (fun t -> Futil.map_title_strings (fun s -> Istr2New (db2, s)) t) - p.Def.titles); - get_pevents = - (fun (db2, _i, p) -> - List.map - (fun t -> - Futil.map_pers_event (fun x -> x) (fun s -> Istr2New (db2, s)) t) - p.Def.pevents); - gen_person_of_person = - (fun (db2, _i, p) -> - Futil.map_person_ps (fun p -> p) (fun s -> Istr2New (db2, s)) p); - dsk_person_of_person = - (fun (_db2, _i, _p) -> failwith "not impl dsk_person_of_person (gen)"); - get_consang = (fun (_db2, _i, a) -> a.Def.consang); - get_parents = (fun (_db2, _i, a) -> a.Def.parents); - get_family = fun (_db2, _i, u) -> u.Def.family} - -(* Persons - user functions *) - -let get_set_per1 = (fun p -> p.per1), (fun p v -> p.per1 <- v) -let get_set_asc1 = (fun p -> p.asc1), (fun p v -> p.asc1 <- v) -let get_set_uni1 = (fun p -> p.uni1), (fun p v -> p.uni1 <- v) - -let get_set_per2 = (fun p -> p.per2), (fun p v -> p.per2 <- v) -let get_set_asc2 = (fun p -> p.asc2), (fun p v -> p.asc2 <- v) -let get_set_uni2 = (fun p -> p.uni2), (fun p v -> p.uni2 <- v) - -let wrap_per f g h = - function - Person (base, i, p) -> - let per = milazy_force base.data.persons.get i get_set_per1 p in - f person1_fun per - | Person2 (db2, i, p) -> - let per = - milazy_force (ht_find db2.patches.h_person) (Adef.iper_of_int i) - get_set_per2 p - in - match per with - Some p -> h person2gen_fun (db2, i, p) - | None -> g person2_fun (db2, i) - -let wrap_asc f g h = - function - Person (base, i, p) -> - let asc = milazy_force base.data.ascends.get i get_set_asc1 p in - f person1_fun asc - | Person2 (db2, i, p) -> - let asc = - milazy_force (ht_find db2.patches.h_ascend) (Adef.iper_of_int i) - get_set_asc2 p - in - match asc with - Some a -> h person2gen_fun (db2, i, a) - | None -> g person2_fun (db2, i) - -let wrap_uni f g h = - function - Person (base, i, p) -> - let uni = milazy_force base.data.unions.get i get_set_uni1 p in - f person1_fun uni - | Person2 (db2, i, p) -> - let uni = - milazy_force (ht_find db2.patches.h_union) (Adef.iper_of_int i) - get_set_uni2 p - in - match uni with - Some u -> h person2gen_fun (db2, i, u) - | None -> g person2_fun (db2, i) - -let get_access p = let f pf = pf.get_access in wrap_per f f f p -let get_aliases p = let f pf = pf.get_aliases in wrap_per f f f p -let get_baptism p = let f pf = pf.get_baptism in wrap_per f f f p -let get_baptism_place p = let f pf = pf.get_baptism_place in wrap_per f f f p -let get_baptism_note p = let f pf = pf.get_baptism_note in wrap_per f f f p -let get_baptism_src p = let f pf = pf.get_baptism_src in wrap_per f f f p -let get_birth p = let f pf = pf.get_birth in wrap_per f f f p -let get_birth_place p = let f pf = pf.get_birth_place in wrap_per f f f p -let get_birth_note p = let f pf = pf.get_birth_note in wrap_per f f f p -let get_birth_src p = let f pf = pf.get_birth_src in wrap_per f f f p -let get_burial p = let f pf = pf.get_burial in wrap_per f f f p -let get_burial_place p = let f pf = pf.get_burial_place in wrap_per f f f p -let get_burial_note p = let f pf = pf.get_burial_note in wrap_per f f f p -let get_burial_src p = let f pf = pf.get_burial_src in wrap_per f f f p -let get_death p = let f pf = pf.get_death in wrap_per f f f p -let get_death_place p = let f pf = pf.get_death_place in wrap_per f f f p -let get_death_note p = let f pf = pf.get_death_note in wrap_per f f f p -let get_death_src p = let f pf = pf.get_death_src in wrap_per f f f p -let get_pevents p = let f pf = pf.get_pevents in wrap_per f f f p -let get_first_name p = let f pf = pf.get_first_name in wrap_per f f f p -let get_first_names_aliases p = - let f pf = pf.get_first_names_aliases in wrap_per f f f p -let get_image p = let f pf = pf.get_image in wrap_per f f f p -let get_key_index p = let f pf = pf.get_key_index in wrap_per f f f p -let get_notes p = let f pf = pf.get_notes in wrap_per f f f p -let get_occ p = let f pf = pf.get_occ in wrap_per f f f p -let get_occupation p = let f pf = pf.get_occupation in wrap_per f f f p -let get_psources p = let f pf = pf.get_psources in wrap_per f f f p -let get_public_name p = let f pf = pf.get_public_name in wrap_per f f f p -let get_qualifiers p = let f pf = pf.get_qualifiers in wrap_per f f f p -let get_related p = let f pf = pf.get_related in wrap_per f f f p -let get_rparents p = let f pf = pf.get_rparents in wrap_per f f f p -let get_sex p = let f pf = pf.get_sex in wrap_per f f f p -let get_surname p = let f pf = pf.get_surname in wrap_per f f f p -let get_surnames_aliases p = - let f pf = pf.get_surnames_aliases in wrap_per f f f p -let get_titles p = let f pf = pf.get_titles in wrap_per f f f p - -let gen_person_of_person p = - let f pf = pf.gen_person_of_person in wrap_per f f f p -let dsk_person_of_person p = - let f pf = pf.dsk_person_of_person in wrap_per f f f p - -let get_consang a = - let f pf = pf.get_consang in - match a with - Person2 (db2, i, _) -> - begin match db2.consang_array with - Some tab -> tab.(i) - | None -> wrap_asc f f f a - end - | _ -> wrap_asc f f f a -let get_parents a = - let f pf = pf.get_parents in - match a with - Person2 (db2, i, _) -> - begin match db2.parents_array with - Some tab -> tab.(i) - | None -> wrap_asc f f f a - end - | _ -> wrap_asc f f f a - -let get_family u = let f pf = pf.get_family in wrap_uni f f f u - -(* Families - common definitions *) - -type family = - Family of dsk_base * int * family1_dat - | Family2 of db2 * int * family2_dat -and family1_dat = - { mutable fam1 : dsk_family option; - mutable cpl1 : dsk_couple option; - mutable des1 : dsk_descend option } -and family2_dat = - { mutable fam2 : (iper, string) gen_family option option; - mutable cpl2 : iper gen_couple option option; - mutable des2 : iper gen_descend option option } - -type ('f, 'c, 'd) family_fun = - { get_ifam : 'f -> ifam; - get_comment : 'f -> istr; - get_divorce : 'f -> Def.divorce; - get_fsources : 'f -> istr; - get_fevents : 'f -> fam_event list; - get_marriage : 'f -> cdate; - get_marriage_place : 'f -> istr; - get_marriage_note : 'f -> istr; - get_marriage_src : 'f -> istr; - get_origin_file : 'f -> istr; - get_relation : 'f -> Def.relation_kind; - get_witnesses : 'f -> iper array; - gen_family_of_family : 'f -> (iper, istr) Def.gen_family; - is_deleted_family : 'f -> bool; - get_father : 'c -> iper; - get_mother : 'c -> iper; - get_parent_array : 'c -> iper array; - gen_couple_of_couple : 'c -> iper Def.gen_couple; - get_children : 'd -> iper array; - gen_descend_of_descend : 'd -> iper Def.gen_descend } - -(* Families - implementation database 1 *) - -let family1_fun = - {get_ifam = (fun f -> f.Def.fam_index); - get_comment = (fun f -> Istr f.Def.comment); - get_divorce = (fun f -> f.Def.divorce); - get_fsources = (fun f -> Istr f.Def.fsources); - get_fevents = - (fun f -> - List.map (fun t -> Futil.map_fam_event (fun x -> x) (fun i -> Istr i) t) - f.Def.fevents); - get_marriage = (fun f -> f.Def.marriage); - get_marriage_place = (fun f -> Istr f.Def.marriage_place); - get_marriage_note = (fun f -> Istr f.Def.marriage_note); - get_marriage_src = (fun f -> Istr f.Def.marriage_src); - get_origin_file = (fun f -> Istr f.Def.origin_file); - get_relation = (fun f -> f.Def.relation); - get_witnesses = (fun f -> f.Def.witnesses); - gen_family_of_family = - (fun f -> Futil.map_family_ps (fun p -> p) (fun s -> Istr s) f); - is_deleted_family = (fun f -> f.Def.fam_index = Adef.ifam_of_int (-1)); - get_father = (fun c -> Adef.father c); - get_mother = (fun c -> Adef.mother c); - get_parent_array = (fun c -> Adef.parent_array c); - gen_couple_of_couple = (fun c -> c); - get_children = (fun d -> d.Def.children); - gen_descend_of_descend = fun d -> d} - -(* Families - implementation database 2 *) - -let family2_fun = - let rec self = - {get_ifam = (fun _ -> assert false); - get_comment = (fun (db2, i) -> make_istr2 db2 ("family", "comment") i); - get_divorce = (fun (db2, i) -> get_field db2 i ("family", "divorce")); - get_fsources = (fun (db2, i) -> make_istr2 db2 ("family", "fsources") i); - get_fevents = - (fun (db2, i) -> - let list = get_list_field db2 i ("family", "fevents") in - List.map - (Futil.map_fam_event (fun x -> x) - (fun pos -> Istr2 (db2, ("family", "fevents"), pos))) - list); - get_marriage = (fun (db2, i) -> get_field db2 i ("family", "marriage")); - get_marriage_place = - (fun (db2, i) -> make_istr2 db2 ("family", "marriage_place") i); - get_marriage_note = - (fun (db2, i) -> make_istr2 db2 ("family", "marriage_note") i); - get_marriage_src = - (fun (db2, i) -> make_istr2 db2 ("family", "marriage_src") i); - get_origin_file = - (fun (db2, i) -> make_istr2 db2 ("family", "origin_file") i); - get_relation = (fun (db2, i) -> get_field db2 i ("family", "relation")); - get_witnesses = - (fun (db2, i) -> get_field db2 i ("family", "witnesses")); - gen_family_of_family = - (fun ((_db2, i) as f) -> - {marriage = self.get_marriage f; - marriage_place = self.get_marriage_place f; - marriage_note = self.get_marriage_note f; - marriage_src = self.get_marriage_src f; - witnesses = self.get_witnesses f; relation = self.get_relation f; - divorce = self.get_divorce f; fevents = self.get_fevents f; - comment = self.get_comment f; origin_file = self.get_origin_file f; - fsources = self.get_fsources f; fam_index = Adef.ifam_of_int i}); - is_deleted_family = - (fun (db2, i) -> - let fath = - match db2.father_array with - Some tab -> tab.(i) - | None -> get_field db2 i ("family", "father") - in - Adef.int_of_iper fath < 0); - get_father = - (fun (db2, i) -> - match db2.father_array with - Some tab -> tab.(i) - | None -> get_field db2 i ("family", "father")); - get_mother = - (fun (db2, i) -> - match db2.mother_array with - Some tab -> tab.(i) - | None -> get_field db2 i ("family", "mother")); - get_parent_array = - (fun (db2, i) -> - let p1 = get_field db2 i ("family", "father") in - let p2 = get_field db2 i ("family", "mother") in [| p1; p2 |]); - gen_couple_of_couple = - (fun c -> Adef.couple (self.get_father c) (self.get_mother c)); - get_children = - (fun (db2, i) -> - match db2.children_array with - Some tab -> tab.(i) - | None -> get_field db2 i ("family", "children")); - gen_descend_of_descend = fun d -> {children = self.get_children d}} - in - self - -let family2gen_fun = - {get_ifam = (fun _ -> assert false); - get_comment = (fun (db2, f) -> Istr2New (db2, f.Def.comment)); - get_divorce = (fun (_db2, f) -> f.Def.divorce); - get_fsources = (fun (db2, f) -> Istr2New (db2, f.Def.fsources)); - get_fevents = - (fun (db2, f) -> - List.map - (fun t -> Futil.map_fam_event (fun x -> x) (fun s -> Istr2New (db2, s)) t) - f.Def.fevents); - get_marriage = (fun (_db2, f) -> f.Def.marriage); - get_marriage_place = - (fun (db2, f) -> Istr2New (db2, f.Def.marriage_place)); - get_marriage_note = (fun (db2, f) -> Istr2New (db2, f.Def.marriage_note)); - get_marriage_src = (fun (db2, f) -> Istr2New (db2, f.Def.marriage_src)); - get_origin_file = (fun (db2, f) -> Istr2New (db2, f.Def.origin_file)); - get_relation = (fun (_db2, f) -> f.Def.relation); - get_witnesses = (fun (_db2, f) -> f.Def.witnesses); - gen_family_of_family = - (fun (db2, f) -> - Futil.map_family_ps (fun p -> p) (fun s -> Istr2New (db2, s)) f); - is_deleted_family = - (fun (_db2, f) -> f.Def.fam_index = Adef.ifam_of_int (-1)); - get_father = (fun (_db2, c) -> Adef.father c); - get_mother = (fun (_db2, c) -> Adef.mother c); - get_parent_array = (fun (_db2, c) -> Adef.parent_array c); - gen_couple_of_couple = (fun (_db2, c) -> c); - get_children = (fun (_db2, d) -> d.Def.children); - gen_descend_of_descend = fun (_db2, d) -> d} - -(* Families - user functions *) - -let get_set_fam1 = (fun p -> p.fam1), (fun p v -> p.fam1 <- v) -let get_set_cpl1 = (fun p -> p.cpl1), (fun p v -> p.cpl1 <- v) -let get_set_des1 = (fun p -> p.des1), (fun p v -> p.des1 <- v) - -let get_set_fam2 = (fun p -> p.fam2), (fun p v -> p.fam2 <- v) -let get_set_cpl2 = (fun p -> p.cpl2), (fun p v -> p.cpl2 <- v) -let get_set_des2 = (fun p -> p.des2), (fun p v -> p.des2 <- v) - -let wrap_fam f g h = - function - Family (base, i, d) -> - let fam = milazy_force base.data.families.get i get_set_fam1 d in - f family1_fun fam - | Family2 (db2, i, d) -> - let fam = - milazy_force (ht_find db2.patches.h_family) (Adef.ifam_of_int i) - get_set_fam2 d - in - match fam with - Some fam -> h family2gen_fun (db2, fam) - | None -> g family2_fun (db2, i) - -let wrap_cpl f g h = - function - Family (base, i, d) -> - let cpl = milazy_force base.data.couples.get i get_set_cpl1 d in - f family1_fun cpl - | Family2 (db2, i, d) -> - let cpl = - milazy_force (ht_find db2.patches.h_couple) (Adef.ifam_of_int i) - get_set_cpl2 d - in - match cpl with - Some cpl -> h family2gen_fun (db2, cpl) - | None -> g family2_fun (db2, i) - -let wrap_des f g h = - function - Family (base, i, d) -> - let des = milazy_force base.data.descends.get i get_set_des1 d in - f family1_fun des - | Family2 (db2, i, d) -> - let des = - milazy_force (ht_find db2.patches.h_descend) (Adef.ifam_of_int i) - get_set_des2 d - in - match des with - Some des -> h family2gen_fun (db2, des) - | None -> g family2_fun (db2, i) - -let get_ifam fam = let f pf = pf.get_ifam in wrap_fam f f f fam -let get_comment fam = let f pf = pf.get_comment in wrap_fam f f f fam -let get_divorce fam = let f pf = pf.get_divorce in wrap_fam f f f fam -let get_fsources fam = let f pf = pf.get_fsources in wrap_fam f f f fam -let get_fevents fam = let f pf = pf.get_fevents in wrap_fam f f f fam -let get_marriage fam = let f pf = pf.get_marriage in wrap_fam f f f fam -let get_marriage_place fam = - let f pf = pf.get_marriage_place in wrap_fam f f f fam -let get_marriage_note fam = - let f pf = pf.get_marriage_note in wrap_fam f f f fam -let get_marriage_src fam = - let f pf = pf.get_marriage_src in wrap_fam f f f fam -let get_origin_file fam = let f pf = pf.get_origin_file in wrap_fam f f f fam -let get_relation fam = let f pf = pf.get_relation in wrap_fam f f f fam -let get_witnesses fam = let f pf = pf.get_witnesses in wrap_fam f f f fam -let gen_family_of_family fam = - let f pf = pf.gen_family_of_family in wrap_fam f f f fam -let is_deleted_family fam = - let f pf = pf.is_deleted_family in wrap_fam f f f fam - -let get_father cpl = - let f pf = pf.get_father in - match cpl with - Family2 (db2, i, _) -> - begin match db2.father_array with - Some tab -> tab.(i) - | None -> wrap_cpl f f f cpl - end - | _ -> wrap_cpl f f f cpl -let get_mother cpl = - let f pf = pf.get_mother in - match cpl with - Family2 (db2, i, _) -> - begin match db2.mother_array with - Some tab -> tab.(i) - | None -> wrap_cpl f f f cpl - end - | _ -> wrap_cpl f f f cpl -let get_parent_array cpl = - let f pf = pf.get_parent_array in wrap_cpl f f f cpl -let gen_couple_of_couple cpl = - let f pf = pf.gen_couple_of_couple in wrap_cpl f f f cpl - -let get_children des = let f pf = pf.get_children in wrap_des f f f des -let gen_descend_of_descend des = - let f pf = pf.gen_descend_of_descend in wrap_des f f f des - -(* Databases - common definitions *) - -type base = - { close_base : unit -> unit; - empty_person : iper -> person; - person_of_gen_person : - (iper, istr) gen_person * ifam gen_ascend * ifam gen_union -> person; - family_of_gen_family : - (iper, istr) gen_family * iper gen_couple * iper gen_descend -> family; - poi : iper -> person; - foi : ifam -> family; - sou : istr -> string; - nb_of_persons : unit -> int; - nb_of_families : unit -> int; - patch_person : iper -> (iper, istr) Def.gen_person -> unit; - patch_ascend : iper -> ifam Def.gen_ascend -> unit; - patch_union : iper -> ifam Def.gen_union -> unit; - patch_family : ifam -> (iper, istr) Def.gen_family -> unit; - patch_descend : ifam -> iper Def.gen_descend -> unit; - patch_couple : ifam -> iper Def.gen_couple -> unit; - patch_name : string -> iper -> unit; - patch_key : iper -> string -> string -> int -> unit; - delete_key : string -> string -> int -> unit; - insert_string : string -> istr; - commit_patches : unit -> unit; - commit_notes : string -> string -> unit; - is_patched_person : iper -> bool; - patched_ascends : unit -> iper list; - delete_family : ifam -> unit; - person_of_key : string -> string -> int -> iper option; - persons_of_name : string -> iper list; - persons_of_first_name : unit -> string_person_index; - persons_of_surname : unit -> string_person_index; - base_visible_get : (person -> bool) -> int -> bool; - base_visible_write : unit -> unit; - base_particles : unit -> string list; - base_strings_of_first_name : string -> istr list; - base_strings_of_surname : string -> istr list; - load_ascends_array : unit -> unit; - load_unions_array : unit -> unit; - load_couples_array : unit -> unit; - load_descends_array : unit -> unit; - load_strings_array : unit -> unit; - load_persons_array : unit -> unit; - load_families_array : unit -> unit; - clear_ascends_array : unit -> unit; - clear_unions_array : unit -> unit; - clear_couples_array : unit -> unit; - clear_descends_array : unit -> unit; - clear_strings_array : unit -> unit; - clear_persons_array : unit -> unit; - clear_families_array : unit -> unit; - persons_array : - unit -> - (int -> (iper, istr) gen_person) * - (int -> (iper, istr) gen_person -> unit); - ascends_array : - unit -> - (int -> ifam option) * (int -> Adef.fix) * (int -> Adef.fix -> unit) * - Adef.fix array option; - base_notes_read : string -> string; - base_notes_read_first_line : string -> string; - base_notes_are_empty : string -> bool; - base_notes_origin_file : unit -> string; - base_notes_dir : unit -> string; - base_wiznotes_dir : unit -> string; - nobtit : string list Lazy.t -> string list Lazy.t -> person -> title list; - p_first_name : person -> string; - p_surname : person -> string; - date_of_last_change : unit -> float; - apply_base1 : (Dbdisk.dsk_base -> unit) -> unit; - apply_base2 : (Db2disk.db2 -> unit) -> unit } - -module C_base : - sig - val delete_family : base -> ifam -> unit - val nobtit : - base -> string list Lazy.t -> string list Lazy.t -> person -> title list - val p_first_name : base -> person -> string - val p_surname : base -> person -> string - end = - struct - let delete_family (self : base) ifam = - let cpl = Adef.couple (Adef.iper_of_int (-1)) (Adef.iper_of_int (-1)) in - let fam = - let empty = self.insert_string "" in - {marriage = Adef.cdate_None; marriage_place = empty; - marriage_note = empty; marriage_src = empty; relation = Married; - divorce = NotDivorced; fevents = []; witnesses = [| |]; - comment = empty; origin_file = empty; fsources = empty; - fam_index = Adef.ifam_of_int (-1)} - in - let des = {children = [| |]} in - self.patch_family ifam fam; - self.patch_couple ifam cpl; - self.patch_descend ifam des - let nobtit self allowed_titles denied_titles p = - let list = get_titles p in - match Lazy.force allowed_titles with - [] -> list - | allowed_titles -> - let list = - List.fold_right - (fun t l -> - let id = Name.lower (self.sou t.t_ident) in - let pl = Name.lower (self.sou t.t_place) in - if pl = "" then - if List.mem id allowed_titles then t :: l else l - else if - List.mem (id ^ "/" ^ pl) allowed_titles || - List.mem (id ^ "/*") allowed_titles - then - t :: l - else l) - list [] - in - match Lazy.force denied_titles with - [] -> list - | denied_titles -> - List.filter - (fun t -> - let id = Name.lower (self.sou t.t_ident) in - let pl = Name.lower (self.sou t.t_place) in - if List.mem (id ^ "/" ^ pl) denied_titles || - List.mem ("*/" ^ pl) denied_titles - then - false - else true) - list - let p_first_name self p = Mutil.nominative (self.sou (get_first_name p)) - let p_surname self p = Mutil.nominative (self.sou (get_surname p)) - end - -(* Database - implementation 1 *) - -let base1 base = - let base_strings_of_first_name_or_surname s = - List.map (fun s -> Istr s) (base.func.strings_of_fsname s) - in - let rec self = - {close_base = base.func.cleanup; - empty_person = - (fun ip -> - Person - (base, Adef.int_of_iper ip, - {per1 = Some (no_person (Adef.istr_of_int 0) ip); - asc1 = Some no_ascend; uni1 = Some no_union})); - person_of_gen_person = - (fun (p, a, u) -> - Person - (base, 0, - {per1 = Some (Futil.map_person_ps (fun p -> p) un_istr p); - asc1 = Some a; uni1 = Some u})); - family_of_gen_family = - (fun (f, c, d) -> - Family - (base, 0, - {fam1 = Some (Futil.map_family_ps (fun p -> p) un_istr f); - cpl1 = Some c; des1 = Some d})); - poi = - (fun i -> - Person - (base, Adef.int_of_iper i, - {per1 = None; asc1 = None; uni1 = None})); - foi = - (fun i -> - Family - (base, Adef.int_of_ifam i, - {fam1 = None; cpl1 = None; des1 = None})); - sou = - (fun i -> - match i with - Istr i -> base.data.strings.get (Adef.int_of_istr i) - | _ -> assert false); - nb_of_persons = (fun () -> base.data.persons.len); - nb_of_families = (fun () -> base.data.families.len); - patch_person = - (fun ip p -> - let p = Futil.map_person_ps (fun p -> p) un_istr p in - base.func.Dbdisk.patch_person ip p); - patch_ascend = (fun ip a -> base.func.Dbdisk.patch_ascend ip a); - patch_union = (fun ip u -> base.func.Dbdisk.patch_union ip u); - patch_family = - (fun ifam f -> - let f = Futil.map_family_ps (fun p -> p) un_istr f in - base.func.Dbdisk.patch_family ifam f); - patch_descend = (fun ifam d -> base.func.Dbdisk.patch_descend ifam d); - patch_couple = (fun ifam c -> base.func.Dbdisk.patch_couple ifam c); - patch_name = (fun s ip -> base.func.Dbdisk.patch_name s ip); - patch_key = (fun _ip _fn _sn _occ -> ()); - delete_key = (fun _fn _sn _occ -> ()); - insert_string = (fun s -> Istr (base.func.Dbdisk.insert_string s)); - commit_patches = base.func.Dbdisk.commit_patches; - commit_notes = base.func.Dbdisk.commit_notes; - is_patched_person = (fun ip -> base.func.Dbdisk.is_patched_person ip); - patched_ascends = base.func.Dbdisk.patched_ascends; - delete_family = (fun ifam -> C_base.delete_family self ifam); - person_of_key = base.func.Dbdisk.person_of_key; - persons_of_name = base.func.Dbdisk.persons_of_name; - persons_of_first_name = - (fun () -> Spi base.func.Dbdisk.persons_of_first_name); - persons_of_surname = (fun () -> Spi base.func.Dbdisk.persons_of_surname); - base_visible_get = - (fun f -> - base.data.visible.v_get - (fun p -> - f - (Person - (base, 0, {per1 = Some p; asc1 = None; uni1 = None})))); - base_visible_write = base.data.visible.v_write; - base_particles = (fun () -> base.data.particles); - base_strings_of_first_name = base_strings_of_first_name_or_surname; - base_strings_of_surname = base_strings_of_first_name_or_surname; - load_ascends_array = base.data.ascends.load_array; - load_unions_array = base.data.unions.load_array; - load_couples_array = base.data.couples.load_array; - load_descends_array = base.data.descends.load_array; - load_strings_array = base.data.strings.load_array; - load_persons_array = base.data.persons.load_array; - load_families_array = base.data.families.load_array; - clear_ascends_array = base.data.ascends.clear_array; - clear_unions_array = base.data.unions.clear_array; - clear_couples_array = base.data.couples.clear_array; - clear_descends_array = base.data.descends.clear_array; - clear_strings_array = base.data.strings.clear_array; - clear_persons_array = base.data.persons.clear_array; - clear_families_array = base.data.families.clear_array; - persons_array = - (fun () -> - let get i = - let p = base.data.persons.get i in - Futil.map_person_ps (fun p -> p) (fun i -> Istr i) p - in - let set i p = - let p = Futil.map_person_ps (fun p -> p) un_istr p in - base.data.persons.set i p - in - get, set); - ascends_array = - (fun () -> - let fget i = (base.data.ascends.get i).parents in - let cget i = (base.data.ascends.get i).consang in - let cset i v = - base.data.ascends.set i - {(base.data.ascends.get i) with consang = v} - in - fget, cget, cset, None); - base_notes_read = (fun fnotes -> base.data.bnotes.nread fnotes RnAll); - base_notes_read_first_line = - (fun fnotes -> base.data.bnotes.nread fnotes Rn1Ln); - base_notes_are_empty = - (fun fnotes -> base.data.bnotes.nread fnotes RnDeg = ""); - base_notes_origin_file = (fun () -> base.data.bnotes.norigin_file); - base_notes_dir = (fun () -> "notes_d"); - base_wiznotes_dir = (fun () -> "wiznotes"); - nobtit = (fun conf p -> C_base.nobtit self conf p); - p_first_name = (fun p -> C_base.p_first_name self p); - p_surname = (fun p -> C_base.p_surname self p); - date_of_last_change = - (fun () -> - let s = - let bdir = base.data.bdir in - try Unix.stat (Filename.concat bdir "patches") with - Unix.Unix_error (_, _, _) -> - Unix.stat (Filename.concat bdir "base") - in - s.Unix.st_mtime); - apply_base1 = (fun f -> f base); - apply_base2 = fun _f -> invalid_arg "apply_base2"} - in - self - -(* Database - implementation 2 *) - -let base2 db2 = - let base_strings_of_first_name_or_surname field proj s = - let posl = strings2_of_fsname db2 field s in - let istrl = - List.map (fun pos -> Istr2 (db2, ("person", field), pos)) posl - in - let s = Name.crush_lower s in - let sl = - Hashtbl.fold - (fun _ p sl -> - if Name.crush_lower (proj p) = s then proj p :: sl else sl) - db2.patches.h_person [] - in - let sl = List.sort_uniq compare sl in - List.fold_left (fun istrl s -> Istr2New (db2, s) :: istrl) istrl sl - in - let rec self = - {close_base = - (fun () -> - Hashtbl.iter (fun (_f1, _f2, _f) ic -> close_in ic) db2.cache_chan); - empty_person = - (fun ip -> - Person2 - (db2, Adef.int_of_iper ip, - {per2 = Some (Some (no_person "" ip)); - asc2 = Some (Some no_ascend); uni2 = Some (Some no_union)})); - person_of_gen_person = - (fun (p, a, u) -> - Person2 - (db2, Adef.int_of_iper p.key_index, - {per2 = Some (Some (Futil.map_person_ps (fun p -> p) un_istr2 p)); - asc2 = Some (Some a); uni2 = Some (Some u)})); - family_of_gen_family = - (fun (f, c, d) -> - Family2 - (db2, Adef.int_of_ifam f.fam_index, - {fam2 = Some (Some (Futil.map_family_ps (fun p -> p) un_istr2 f)); - cpl2 = Some (Some c); des2 = Some (Some d)})); - poi = - (fun i -> - Person2 - (db2, Adef.int_of_iper i, - {per2 = None; asc2 = None; uni2 = None})); - foi = - (fun i -> - Family2 - (db2, Adef.int_of_ifam i, - {fam2 = None; cpl2 = None; des2 = None})); - sou = - (fun i -> - match i with - Istr2 (db2, f, pos) -> string_of_istr2 db2 f pos - | Istr2New (_db2, s) -> s - | _ -> assert false); - nb_of_persons = (fun () -> db2.patches.nb_per); - nb_of_families = (fun () -> db2.patches.nb_fam); - patch_person = - (fun ip p -> - let p = Futil.map_person_ps (fun p -> p) un_istr2 p in - Hashtbl.replace db2.patches.h_person ip p; - db2.patches.nb_per <- - max (Adef.int_of_iper ip + 1) db2.patches.nb_per); - patch_ascend = - (fun ip a -> - Hashtbl.replace db2.patches.h_ascend ip a; - db2.patches.nb_per <- - max (Adef.int_of_iper ip + 1) db2.patches.nb_per); - patch_union = - (fun ip u -> - Hashtbl.replace db2.patches.h_union ip u; - db2.patches.nb_per <- - max (Adef.int_of_iper ip + 1) db2.patches.nb_per); - patch_family = - (fun ifam f -> - let f = Futil.map_family_ps (fun p -> p) un_istr2 f in - Hashtbl.replace db2.patches.h_family ifam f; - db2.patches.nb_fam <- - max (Adef.int_of_ifam ifam + 1) db2.patches.nb_fam); - patch_descend = - (fun ifam d -> - Hashtbl.replace db2.patches.h_descend ifam d; - db2.patches.nb_fam <- - max (Adef.int_of_ifam ifam + 1) db2.patches.nb_fam); - patch_couple = - (fun ifam c -> - Hashtbl.replace db2.patches.h_couple ifam c; - db2.patches.nb_fam <- - max (Adef.int_of_ifam ifam + 1) db2.patches.nb_fam); - patch_name = - (fun s ip -> - let s = Name.crush_lower s in - let ht = db2.patches.h_name in - try - let ipl = Hashtbl.find ht s in - if List.mem ip ipl then () else Hashtbl.replace ht s (ip :: ipl) - with Not_found -> Hashtbl.add ht s [ip]); - patch_key = - (fun ip fn sn occ -> - let fn = Name.lower (Mutil.nominative fn) in - let sn = Name.lower (Mutil.nominative sn) in - Hashtbl.replace db2.patches.h_key (fn, sn, occ) (Some ip)); - delete_key = - (fun fn sn occ -> - let fn = Name.lower (Mutil.nominative fn) in - let sn = Name.lower (Mutil.nominative sn) in - match disk_person2_of_key db2 fn sn occ with - Some _ -> Hashtbl.replace db2.patches.h_key (fn, sn, occ) None - | None -> Hashtbl.remove db2.patches.h_key (fn, sn, occ)); - insert_string = (fun s -> Istr2New (db2, s)); - commit_patches = (fun () -> commit_patches2 db2); - commit_notes = (fun fnotes s -> commit_notes2 db2 fnotes s); - is_patched_person = (fun ip -> Hashtbl.mem db2.patches.h_person ip); - patched_ascends = - (fun () -> - let r = ref [] in - Hashtbl.iter (fun ip _ -> r := ip :: !r) db2.patches.h_ascend; !r); - delete_family = (fun ifam -> C_base.delete_family self ifam); - person_of_key = (fun fn sn oc -> person2_of_key db2 fn sn oc); - persons_of_name = (fun s -> persons2_of_name db2 s); - persons_of_first_name = - (fun () -> Spi2 (db2, persons_of_first_name_or_surname2 db2 true)); - persons_of_surname = - (fun () -> Spi2 (db2, persons_of_first_name_or_surname2 db2 false)); - base_visible_get = (fun _f -> failwith "not impl visible_get"); - base_visible_write = (fun () -> failwith "not impl visible_write"); - base_particles = - (fun () -> - Mutil.input_particles (Filename.concat db2.bdir2 "particles.txt")); - base_strings_of_first_name = - (fun s -> - base_strings_of_first_name_or_surname "first_name" - (fun p -> p.first_name) s); - base_strings_of_surname = - (fun s -> - base_strings_of_first_name_or_surname "surname" (fun p -> p.surname) - s); - load_ascends_array = - (fun () -> - Printf.eprintf "*** loading ascends array\n"; - flush stderr; - let nb = db2.patches.nb_per in - let nb_ini = db2.patches.nb_per_ini in - begin match db2.parents_array with - Some _ -> () - | None -> db2.parents_array <- Some (parents_array2 db2 nb_ini nb) - end; - match db2.consang_array with - Some _ -> () - | None -> db2.consang_array <- Some (consang_array2 db2 nb)); - load_unions_array = - (fun () -> - match db2.family_array with - Some _ -> () - | None -> - Printf.eprintf "*** loading unions array\n"; - flush stderr; - db2.family_array <- Some (family_array2 db2)); - load_couples_array = (fun () -> load_couples_array2 db2); - load_descends_array = - (fun () -> - match db2.children_array with - Some _ -> () - | None -> - Printf.eprintf "*** loading descends array\n"; - flush stderr; - db2.children_array <- Some (children_array2 db2)); - load_strings_array = (fun () -> ()); - load_persons_array = (fun () -> ()); - load_families_array = (fun () -> ()); - clear_ascends_array = - (fun () -> db2.parents_array <- None); - clear_unions_array = - (fun () -> db2.family_array <- None); - clear_couples_array = (fun () -> - db2.father_array <- None ; - db2.mother_array <- None ); - clear_descends_array = - (fun () -> db2.children_array <- None); - clear_strings_array = (fun () -> ()); - clear_persons_array = (fun () -> ()); - clear_families_array = (fun () -> ()); - persons_array = (fun () -> failwith "not impl persons_array"); - ascends_array = - (fun () -> - let nb = db2.patches.nb_per in - let nb_ini = db2.patches.nb_per_ini in - let ptab = - match db2.parents_array with - Some tab -> tab - | None -> parents_array2 db2 nb_ini nb - in - let cg_tab = - match db2.consang_array with - Some tab -> tab - | None -> consang_array2 db2 nb - in - let fget i = ptab.(i) in - let cget i = cg_tab.(i) in - let cset i v = cg_tab.(i) <- v in fget, cget, cset, Some cg_tab); - base_notes_read = (fun fnotes -> read_notes db2 fnotes RnAll); - base_notes_read_first_line = (fun fnotes -> read_notes db2 fnotes Rn1Ln); - base_notes_are_empty = (fun fnotes -> read_notes db2 fnotes RnDeg = ""); - base_notes_origin_file = - (fun () -> - let fname = Filename.concat db2.bdir2 "notes_of.txt" in - try - let ic = Secure.open_in fname in - let r = input_line ic in - close_in ic; - r - with Sys_error _ -> ""); - base_notes_dir = (fun () -> Filename.concat "base_d" "notes_d"); - base_wiznotes_dir = (fun () -> Filename.concat "base_d" "wiznotes_d"); - nobtit = (fun conf p -> C_base.nobtit self conf p); - p_first_name = (fun p -> C_base.p_first_name self p); - p_surname = (fun p -> C_base.p_surname self p); - date_of_last_change = - (fun () -> - let s = - let bdir = db2.bdir2 in - try Unix.stat (Filename.concat bdir "patches") with - Unix.Unix_error (_, _, _) -> Unix.stat bdir - in - s.Unix.st_mtime); - apply_base1 = (fun _f -> invalid_arg "apply_base1"); - apply_base2 = fun f -> f db2} - in - self - -(* Database - user functions *) - -let open_base bname = - let bname = - if Filename.check_suffix bname ".gwb" then bname else bname ^ ".gwb" - in - if Sys.file_exists (Filename.concat bname "base_d") then - base2 (base_of_base2 bname) - else base1 (Database.opendb bname) - -let close_base (b : base) = b.close_base () -let empty_person (b : base) = b.empty_person -let person_of_gen_person (b : base) = b.person_of_gen_person -let family_of_gen_family (b : base) = b.family_of_gen_family -let poi (b : base) = b.poi -let foi (b : base) = b.foi -let sou (b : base) = b.sou -let nb_of_persons (b : base) = b.nb_of_persons () -let nb_of_families (b : base) = b.nb_of_families () -let patch_person (b : base) = b.patch_person -let patch_ascend (b : base) = b.patch_ascend -let patch_union (b : base) = b.patch_union -let patch_family (b : base) = b.patch_family -let patch_descend (b : base) = b.patch_descend -let patch_couple (b : base) = b.patch_couple -let patch_name (b : base) = b.patch_name -let patch_key (b : base) = b.patch_key -let delete_key (b : base) = b.delete_key -let insert_string (b : base) = b.insert_string -let commit_patches (b : base) = b.commit_patches () -let commit_notes (b : base) = b.commit_notes -let is_patched_person (b : base) = b.is_patched_person -let patched_ascends (b : base) = b.patched_ascends () -let delete_family (b : base) = b.delete_family -let person_of_key (b : base) = b.person_of_key -let persons_of_name (b : base) = b.persons_of_name -let persons_of_first_name (b : base) = b.persons_of_first_name () -let persons_of_surname (b : base) = b.persons_of_surname () -let base_visible_get (b : base) = b.base_visible_get -let base_visible_write (b : base) = b.base_visible_write () -let base_particles (b : base) = b.base_particles () -let base_strings_of_first_name (b : base) = b.base_strings_of_first_name -let base_strings_of_surname (b : base) = b.base_strings_of_surname -let load_ascends_array (b : base) = b.load_ascends_array () -let load_unions_array (b : base) = b.load_unions_array () -let load_couples_array (b : base) = b.load_couples_array () -let load_descends_array (b : base) = b.load_descends_array () -let load_strings_array (b : base) = b.load_strings_array () -let load_persons_array (b : base) = b.load_persons_array () -let load_families_array (b : base) = b.load_families_array () -let clear_ascends_array (b : base) = b.clear_ascends_array () -let clear_unions_array (b : base) = b.clear_unions_array () -let clear_couples_array (b : base) = b.clear_couples_array () -let clear_descends_array (b : base) = b.clear_descends_array () -let clear_strings_array (b : base) = b.clear_strings_array () -let clear_persons_array (b : base) = b.clear_persons_array () -let clear_families_array (b : base) = b.clear_families_array () -let persons_array (b : base) = b.persons_array () -let ascends_array (b : base) = b.ascends_array () -let base_notes_read (b : base) = b.base_notes_read -let base_notes_read_first_line (b : base) = b.base_notes_read_first_line -let base_notes_are_empty (b : base) = b.base_notes_are_empty -let base_notes_origin_file (b : base) = b.base_notes_origin_file () -let base_notes_dir (b : base) = b.base_notes_dir () -let base_wiznotes_dir (b : base) = b.base_wiznotes_dir () -let nobtit (b : base) = b.nobtit -let p_first_name (b : base) = b.p_first_name -let p_surname (b : base) = b.p_surname -let date_of_last_change (b : base) = b.date_of_last_change () -let base_of_base1 = base1 -let apply_base1 (b : base) = b.apply_base1 -let apply_base2 (b : base) = b.apply_base2 - -let husbands base gp = - let p = poi base gp.key_index in - List.map - (fun ifam -> - let fam = foi base ifam in - let husband = poi base (get_father fam) in - let husband_surname = p_surname base husband in - let husband_surnames_aliases = - List.map (sou base) (get_surnames_aliases husband) - in - husband_surname, husband_surnames_aliases) - (Array.to_list (get_family p)) - -let father_titles_places base p nobtit = - match get_parents (poi base p.key_index) with - Some ifam -> - let fam = foi base ifam in - let fath = poi base (get_father fam) in - List.map (fun t -> sou base t.t_place) (nobtit fath) - | None -> [] - -let gen_gen_person_misc_names base p nobtit nobtit_fun = - let sou = sou base in - Futil.gen_person_misc_names (sou p.first_name) (sou p.surname) - (sou p.public_name) (List.map sou p.qualifiers) (List.map sou p.aliases) - (List.map sou p.first_names_aliases) (List.map sou p.surnames_aliases) - (List.map (Futil.map_title_strings sou) nobtit) - (if p.sex = Female then husbands base p else []) - (father_titles_places base p nobtit_fun) - -let gen_person_misc_names base p nobtit = - gen_gen_person_misc_names base p (nobtit p) - (fun p -> nobtit (gen_person_of_person p)) - -let person_misc_names base p nobtit = - gen_gen_person_misc_names base (gen_person_of_person p) (nobtit p) nobtit +include Gwdb1_internal diff --git a/lib/gwdb1/gwdb1.ml b/lib/gwdb1/gwdb1.ml new file mode 100644 index 0000000000..42fbee72b5 --- /dev/null +++ b/lib/gwdb1/gwdb1.ml @@ -0,0 +1,11 @@ +include Gwdb1_internal + +module ToGwdb = struct + let base : Gwdb1_internal.base -> Gwdb.base = Obj.magic + let person : Gwdb1_internal.person -> Gwdb.person = Obj.magic +end + +module OfGwdb = struct + let base : Gwdb.base -> Gwdb1_internal.base = Obj.magic + let person : Gwdb.person -> Gwdb1_internal.person = Obj.magic +end diff --git a/lib/gwdb1/gwdb1_internal.ml b/lib/gwdb1/gwdb1_internal.ml new file mode 100644 index 0000000000..333564ac83 --- /dev/null +++ b/lib/gwdb1/gwdb1_internal.ml @@ -0,0 +1,314 @@ +(* Copyright (c) 1998-2007 INRIA *) + +open Dbdisk +open Def + +let cache f a (get, set) x = + match get x with + | Some v -> v + | None -> let v = f a in set x (Some v) ; v + +let no_person empty_string ip = + {first_name = empty_string; surname = empty_string; occ = 0; + image = empty_string; first_names_aliases = []; surnames_aliases = []; + public_name = empty_string; qualifiers = []; titles = []; rparents = []; + related = []; aliases = []; occupation = empty_string; sex = Neuter; + access = Private; birth = Adef.cdate_None; birth_place = empty_string; + birth_note = empty_string; birth_src = empty_string; + baptism = Adef.cdate_None; baptism_place = empty_string; + baptism_note = empty_string; baptism_src = empty_string; + death = DontKnowIfDead; death_place = empty_string; + death_note = empty_string; death_src = empty_string; + burial = UnknownBurial; burial_place = empty_string; + burial_note = empty_string; burial_src = empty_string; pevents = []; + notes = empty_string; psources = empty_string; key_index = ip} +let no_ascend = {parents = None; consang = Adef.no_consang} +let no_union = {family = [| |]} + +type istr = dsk_istr + +type relation = (iper, istr) Def.gen_relation +type title = istr Def.gen_title +type pers_event = (iper, istr) Def.gen_pers_event +type fam_event = (iper, istr) Def.gen_fam_event + +let eq_istr i1 i2 = Adef.int_of_istr i1 = Adef.int_of_istr i2 +let is_empty_string istr = Adef.int_of_istr istr = 0 +let is_quest_string istr = Adef.int_of_istr istr = 1 + +type string_person_index = istr Dbdisk.string_person_index + +let spi_find spi = spi.find +let spi_first spi = spi.cursor +let spi_next (spi : string_person_index) istr (_need_whole_list : bool) = spi.next istr, 1 + +type person = dsk_base * int * person_dat +and person_dat = + { mutable p : dsk_person option; + mutable a : dsk_ascend option; + mutable u : dsk_union option } + +let cache_per f (base, i, p) = + f (cache base.data.persons.get i ((fun p -> p.p), (fun p v -> p.p <- v)) p) + +let cache_asc f (base, i, p) = + f (cache base.data.ascends.get i ((fun p -> p.a), (fun p v -> p.a <- v)) p) + +let cache_uni f (base, i, p) = + f (cache base.data.unions.get i ((fun p -> p.u), (fun p v -> p.u <- v)) p) + +let dsk_person_of_person = cache_per (fun p -> p) +let gen_person_of_person = cache_per (fun p -> p) +let get_access = cache_per (fun p -> p.Def.access) +let get_aliases = cache_per (fun p -> p.Def.aliases) +let get_baptism = cache_per (fun p -> p.Def.baptism) +let get_baptism_note = cache_per (fun p -> p.Def.baptism_note) +let get_baptism_place = cache_per (fun p -> p.Def.baptism_place) +let get_baptism_src = cache_per (fun p -> p.Def.baptism_src) +let get_birth = cache_per (fun p -> p.Def.birth) +let get_birth_note = cache_per (fun p -> p.Def.birth_note) +let get_birth_place = cache_per (fun p -> p.Def.birth_place) +let get_birth_src = cache_per (fun p -> p.Def.birth_src) +let get_burial = cache_per (fun p -> p.Def.burial) +let get_burial_note = cache_per (fun p -> p.Def.burial_note) +let get_burial_place = cache_per (fun p -> p.Def.burial_place) +let get_burial_src = cache_per (fun p -> p.Def.burial_src) +let get_consang = cache_asc (fun a -> a.Def.consang) +let get_death = cache_per (fun p -> p.Def.death) +let get_death_note = cache_per (fun p -> p.Def.death_note) +let get_death_place = cache_per (fun p -> p.Def.death_place) +let get_death_src = cache_per (fun p -> p.Def.death_src) +let get_family = cache_uni (fun u -> u.Def.family) +let get_first_name = cache_per (fun p -> p.Def.first_name) +let get_first_names_aliases = cache_per (fun p -> p.Def.first_names_aliases) +let get_image = cache_per (fun p -> p.Def.image) +let get_key_index = cache_per (fun p -> p.Def.key_index) +let get_notes = cache_per (fun p -> p.Def.notes) +let get_occ = cache_per (fun p -> p.Def.occ) +let get_occupation = cache_per (fun p -> p.Def.occupation) +let get_parents = cache_asc (fun a -> a.Def.parents) +let get_pevents = cache_per (fun p -> p.Def.pevents) +let get_psources = cache_per (fun p -> p.Def.psources) +let get_public_name = cache_per (fun p -> p.Def.public_name) +let get_qualifiers = cache_per (fun p -> p.Def.qualifiers) +let get_related = cache_per (fun p -> p.Def.related) +let get_rparents = cache_per (fun p -> p.Def.rparents) +let get_sex = cache_per (fun p -> p.Def.sex) +let get_surname = cache_per (fun p -> p.Def.surname) +let get_surnames_aliases = cache_per (fun p -> p.Def.surnames_aliases) +let get_titles = cache_per (fun p -> p.Def.titles) + +type family_dat = + { mutable f : dsk_family option; + mutable c : dsk_couple option; + mutable d : dsk_descend option } +type family = dsk_base * int * family_dat + +let cache_fam f (base, i, d) = + f (cache base.data.families.get i ((fun f -> f.f), (fun f v -> f.f <- v)) d) + +let cache_cpl f (base, i, d) = + f (cache base.data.couples.get i ((fun f -> f.c), (fun f v -> f.c <- v)) d) + +let cache_des f (base, i, d) = + f (cache base.data.descends.get i ((fun f -> f.d), (fun f v -> f.d <- v)) d) + +let gen_couple_of_couple = cache_cpl (fun c -> c) +let gen_descend_of_descend = cache_des (fun d -> d) +let gen_family_of_family = cache_fam (fun f -> f) +let get_children = cache_des (fun d -> d.Def.children) +let get_comment = cache_fam (fun f -> f.Def.comment) +let get_ifam = cache_fam (fun f -> f.Def.fam_index) +let get_divorce = cache_fam (fun f -> f.Def.divorce) +let get_father = cache_cpl (fun c -> Adef.father c) +let get_fevents = cache_fam (fun f -> f.Def.fevents) +let get_fsources = cache_fam (fun f -> f.Def.fsources) +let get_marriage = cache_fam (fun f -> f.Def.marriage) +let get_marriage_note = cache_fam (fun f -> f.Def.marriage_note) +let get_marriage_place = cache_fam (fun f -> f.Def.marriage_place) +let get_marriage_src = cache_fam (fun f -> f.Def.marriage_src) +let get_mother = cache_cpl (fun c -> Adef.mother c) +let get_origin_file = cache_fam (fun f -> f.Def.origin_file) +let get_parent_array = cache_cpl (fun c -> Adef.parent_array c) +let get_relation = cache_fam (fun f -> f.Def.relation) +let get_witnesses = cache_fam (fun f -> f.Def.witnesses) +let is_deleted_family = cache_fam (fun f -> f.Def.fam_index = Adef.ifam_of_int (-1)) + +type base = dsk_base + +let base_strings_of_first_name_or_surname base s = base.func.strings_of_fsname s +let open_base bname : base = + let bname = if Filename.check_suffix bname ".gwb" then bname else bname ^ ".gwb" in + Database.opendb bname + +let close_base base = base.func.cleanup () +let empty_person base ip = + (base, Adef.int_of_iper ip, {p = Some (no_person (Adef.istr_of_int 0) ip);a = Some no_ascend; u = Some no_union}) +let person_of_gen_person base (p, a, u) = + (base, 0, {p = Some p; a = Some a; u = Some u}) +let family_of_gen_family base (f, c, d) = + (base, 0, {f = Some f; c = Some c; d = Some d}) +let poi base i = + (base, Adef.int_of_iper i,{p = None; a = None; u = None}) +let foi base i = + (base, Adef.int_of_ifam i, {f = None; c = None; d = None}) +let sou base i = base.data.strings.get (Adef.int_of_istr i) +let nb_of_persons base = base.data.persons.len +let nb_of_families base = base.data.families.len +let patch_person base ip p = base.func.Dbdisk.patch_person ip p +let patch_ascend base ip a = base.func.Dbdisk.patch_ascend ip a +let patch_union base ip u = base.func.Dbdisk.patch_union ip u +let patch_family base ifam f = base.func.Dbdisk.patch_family ifam f +let patch_descend base ifam d = base.func.Dbdisk.patch_descend ifam d +let patch_couple base ifam c = base.func.Dbdisk.patch_couple ifam c +let patch_name base s ip = base.func.Dbdisk.patch_name s ip +let patch_key _base _ip _fn _sn _occ = () (* FIXME? *) +let delete_key _base _fn _sn _occ = () (* FIXME? *) +let insert_string base s = base.func.Dbdisk.insert_string s +let commit_patches base = base.func.Dbdisk.commit_patches () +let commit_notes base s = base.func.Dbdisk.commit_notes s + +let is_patched_person base ip = base.func.Dbdisk.is_patched_person ip +let patched_ascends base = base.func.Dbdisk.patched_ascends () +let person_of_key base = base.func.Dbdisk.person_of_key +let persons_of_name base = base.func.Dbdisk.persons_of_name +let persons_of_first_name base = base.func.Dbdisk.persons_of_first_name +let persons_of_surname base = base.func.Dbdisk.persons_of_surname +let base_visible_get base f = + base.data.visible.v_get + (fun p -> f ( (base, 0, {p = Some p; a = None; u = None}))) + +let base_visible_write base = base.data.visible.v_write () +let base_particles base = base.data.particles +let base_strings_of_first_name = base_strings_of_first_name_or_surname +let base_strings_of_surname = base_strings_of_first_name_or_surname +let load_ascends_array base = base.data.ascends.load_array () +let load_unions_array base = base.data.unions.load_array () +let load_couples_array base = base.data.couples.load_array () +let load_descends_array base = base.data.descends.load_array () +let load_strings_array base = base.data.strings.load_array () +let load_persons_array base = base.data.persons.load_array () +let load_families_array base = base.data.families.load_array () +let clear_ascends_array base = base.data.ascends.clear_array () +let clear_unions_array base = base.data.unions.clear_array () +let clear_couples_array base = base.data.couples.clear_array () +let clear_descends_array base = base.data.descends.clear_array () +let clear_strings_array base = base.data.strings.clear_array () +let clear_persons_array base = base.data.persons.clear_array () +let clear_families_array base = base.data.families.clear_array () +let persons_array base = + let get i = base.data.persons.get i in + let set i p = base.data.persons.set i p in + get, set +let ascends_array base = + let fget i = (base.data.ascends.get i).parents in + let cget i = (base.data.ascends.get i).consang in + let cset i v = + base.data.ascends.set i {(base.data.ascends.get i) with consang = v} + in + fget, cget, cset, None +let base_notes_read base fnotes = base.data.bnotes.nread fnotes RnAll +let base_notes_read_first_line base fnotes = base.data.bnotes.nread fnotes Rn1Ln +let base_notes_are_empty base fnotes = base.data.bnotes.nread fnotes RnDeg = "" +let base_notes_origin_file base = base.data.bnotes.norigin_file +let base_notes_dir _base = "notes_d" +let base_wiznotes_dir _base = "wiznotes" + +let date_of_last_change base = + let s = + let bdir = base.data.bdir in + try Unix.stat (Filename.concat bdir "patches") + with Unix.Unix_error (_, _, _) -> Unix.stat (Filename.concat bdir "base") + in + s.Unix.st_mtime + +let apply_base1 base f = f base + +let delete_family base ifam = + let cpl = Adef.couple (Adef.iper_of_int (-1)) (Adef.iper_of_int (-1)) in + let fam = + let empty = insert_string base "" in + {marriage = Adef.cdate_None; marriage_place = empty; + marriage_note = empty; marriage_src = empty; relation = Married; + divorce = NotDivorced; fevents = []; witnesses = [| |]; + comment = empty; origin_file = empty; fsources = empty; + fam_index = Adef.ifam_of_int (-1)} + in + let des = {children = [| |]} in + patch_family base ifam fam; + patch_couple base ifam cpl; + patch_descend base ifam des + +let nobtit base allowed_titles denied_titles p = + let list = get_titles p in + match Lazy.force allowed_titles with + [] -> list + | allowed_titles -> + let list = + List.fold_right + (fun t l -> + let id = Name.lower (sou base t.t_ident) in + let pl = Name.lower (sou base t.t_place) in + if pl = "" then + if List.mem id allowed_titles then t :: l else l + else if + List.mem (id ^ "/" ^ pl) allowed_titles || + List.mem (id ^ "/*") allowed_titles + then + t :: l + else l) + list [] + in + match Lazy.force denied_titles with + [] -> list + | denied_titles -> + List.filter + (fun t -> + let id = Name.lower (sou base t.t_ident) in + let pl = Name.lower (sou base t.t_place) in + if List.mem (id ^ "/" ^ pl) denied_titles || + List.mem ("*/" ^ pl) denied_titles + then + false + else true) + list + +let p_first_name base p = Mutil.nominative (sou base (get_first_name p)) +let p_surname base p = Mutil.nominative (sou base (get_surname p)) + +let husbands base gp = + let p = poi base gp.key_index in + Array.map + (fun ifam -> + let fam = foi base ifam in + let husband = poi base (get_father fam) in + let husband_surname = p_surname base husband in + let husband_surnames_aliases = + List.map (sou base) (get_surnames_aliases husband) + in + husband_surname, husband_surnames_aliases) + (get_family p) + +let father_titles_places base p nobtit = + match get_parents (poi base p.key_index) with + | Some ifam -> + let fam = foi base ifam in + let fath = poi base (get_father fam) in + List.map (fun t -> sou base t.t_place) (nobtit fath) + | None -> [] + +let gen_gen_person_misc_names base p nobtit nobtit_fun = + let sou = sou base in + Futil.gen_person_misc_names (sou p.first_name) (sou p.surname) + (sou p.public_name) (List.map sou p.qualifiers) (List.map sou p.aliases) + (List.map sou p.first_names_aliases) (List.map sou p.surnames_aliases) + (List.map (Futil.map_title_strings sou) nobtit) + (if p.sex = Female then Array.to_list (husbands base p) else []) + (father_titles_places base p nobtit_fun) + +let gen_person_misc_names base p nobtit = + gen_gen_person_misc_names base p (nobtit p) + (fun p -> nobtit (gen_person_of_person p)) + +let person_misc_names base p nobtit = + gen_gen_person_misc_names base (gen_person_of_person p) (nobtit p) nobtit diff --git a/lib/iovalue/dune b/lib/iovalue/dune new file mode 100644 index 0000000000..3dec75aee5 --- /dev/null +++ b/lib/iovalue/dune @@ -0,0 +1,5 @@ +(library + (name io) + (public_name geneweb.io) + (wrapped false) +) diff --git a/lib/util/dune b/lib/util/dune new file mode 100644 index 0000000000..d4df2df01b --- /dev/null +++ b/lib/util/dune @@ -0,0 +1,6 @@ +(library + (name util) + (public_name geneweb.util) + (wrapped false) + (libraries geneweb.def geneweb.io) +) diff --git a/test/dune.in b/test/dune.in index 833095f0d9..c819db3e1c 100644 --- a/test/dune.in +++ b/test/dune.in @@ -1,6 +1,6 @@ (executable (name test) - (libraries %%%SOSA_PKG%%% geneweb oUnit) + (libraries %%%SOSA_PKG%%% %%%GWDB_PKG%%% geneweb oUnit) (modules test test_place test_sosa test_utils) )