776 lines
25 KiB
OCaml
776 lines
25 KiB
OCaml
(* Copyright (c) 1998-2007 INRIA *)
|
|
|
|
open Config
|
|
open Gwdb
|
|
open Util
|
|
|
|
(* max number of persons for which a m=RLM graph will be computed *)
|
|
let max_rlm_nbr_default = 80
|
|
|
|
let suburb_aux sub nosub s =
|
|
let len = String.length s in
|
|
if len = 0 then nosub ""
|
|
else if String.unsafe_get s 0 = '[' then
|
|
match String.index_opt s ']' with
|
|
| None -> nosub s
|
|
| Some i -> (
|
|
match
|
|
let rec loop b i =
|
|
if i = len then None
|
|
else
|
|
match Char.code s.[i] with
|
|
| 0x20 -> loop b (i + 1)
|
|
| 0x2D when not b -> loop true (i + 1) (* hyphen *)
|
|
(* handle en and em dash as well *)
|
|
| 0xE2
|
|
when Char.code s.[i + 1] = 0x80
|
|
&& (Char.code s.[i + 2] = 0x93
|
|
|| Char.code s.[i + 2] = 0x94)
|
|
&& not b ->
|
|
loop true (i + 3)
|
|
| _ -> if b then Some i else None
|
|
in
|
|
loop false (i + 1)
|
|
with
|
|
| None -> nosub s
|
|
| Some j -> sub s len i j)
|
|
else nosub s
|
|
|
|
(** [split_suburb "[foo-bar] - boobar (baz)"] is ["foo-bar", "boobar (baz)")] *)
|
|
let split_suburb =
|
|
suburb_aux
|
|
(fun s len i j -> (String.sub s 1 (i - 1), String.sub s j (len - j)))
|
|
(fun s -> ("", s))
|
|
|
|
(** [only_suburb "[foo-bar] - boobar (baz)"] is ["foo-bar"]
|
|
[only_suburb "boobar (baz)"] is [""] *)
|
|
let only_suburb =
|
|
suburb_aux (fun s _len i _j -> String.sub s 1 (i - 1)) (fun _ -> "")
|
|
|
|
(** [without_suburb "[foo-bar] - boobar (baz)"] is ["boobar (baz)"]
|
|
[without_suburb "boobar (baz)"] is ["boobar (baz)"] *)
|
|
let without_suburb =
|
|
suburb_aux (fun s len _i j -> String.sub s j (len - j)) (fun s -> s)
|
|
|
|
let has_suburb s = String.unsafe_get s 0 = '['
|
|
|
|
type 'a env =
|
|
| Vlist_data of (string * (string * int) list) list
|
|
| Vlist_ini of string list
|
|
| Vlist_value of (string * (string * int) list) list
|
|
| Venv_keys of (string * int) list
|
|
| Vint of int
|
|
| Vstring of string
|
|
| Vbool of bool
|
|
| Vother of 'a
|
|
| Vnone
|
|
|
|
let get_vother = function Vother x -> Some x | _ -> None
|
|
let set_vother x = Vother x
|
|
|
|
let normalize =
|
|
suburb_aux
|
|
(fun s len i j ->
|
|
let b = Bytes.create (len - j + i + 1) in
|
|
Bytes.blit_string s 1 b 0 (i - 1);
|
|
Bytes.unsafe_set b (i - 1) ',';
|
|
Bytes.unsafe_set b i ' ';
|
|
Bytes.blit_string s j b (i + 1) (len - j);
|
|
Bytes.unsafe_to_string b)
|
|
(fun s -> s)
|
|
|
|
let compare_places s1 s2 =
|
|
let ss1, s1 = split_suburb s1 in
|
|
let ss2, s2 = split_suburb s2 in
|
|
match
|
|
Mutil.list_compare Gutil.alphabetic_order
|
|
(String.split_on_char ',' s1)
|
|
(String.split_on_char ',' s2)
|
|
with
|
|
| 0 -> Gutil.alphabetic_order ss1 ss2
|
|
| x -> x
|
|
|
|
let max_rlm_nbr conf =
|
|
match p_getenv conf.env "max_rlm_nbr" with
|
|
| Some n -> (
|
|
match int_of_string_opt n with
|
|
| Some n -> n
|
|
| None -> (
|
|
match List.assoc_opt "max_rlm_nbr" conf.base_env with
|
|
| Some n -> (
|
|
match int_of_string_opt n with
|
|
| Some n -> n
|
|
| None -> max_rlm_nbr_default)
|
|
| None -> max_rlm_nbr_default))
|
|
| None -> (
|
|
match List.assoc_opt "max_rlm_nbr" conf.base_env with
|
|
| Some n -> (
|
|
match int_of_string_opt n with
|
|
| Some n -> n
|
|
| None -> max_rlm_nbr_default)
|
|
| None -> max_rlm_nbr_default)
|
|
|
|
(* [String.length s > 0] is always true because we already tested [is_empty_string].
|
|
If it is not true, then the base should be cleaned. *)
|
|
let fold_place_long inverted s =
|
|
match String.length s with
|
|
| 0 ->
|
|
!GWPARAM.syslog `LOG_WARNING "Zero length string in fold_place_long!";
|
|
([], "")
|
|
| _ ->
|
|
let sub = only_suburb s in
|
|
let s = without_suburb s in
|
|
let len = String.length s in
|
|
(* Trimm spaces after ',' and build reverse String.split_on_char ',' *)
|
|
let rec loop iend list i ibeg =
|
|
if i = iend then
|
|
if i > ibeg then String.sub s ibeg (i - ibeg) :: list else list
|
|
else
|
|
let list, ibeg =
|
|
match String.unsafe_get s i with
|
|
| ',' ->
|
|
let list =
|
|
if i > ibeg then String.sub s ibeg (i - ibeg) :: list
|
|
else list
|
|
in
|
|
(list, i + 1)
|
|
| ' ' when i = ibeg -> (list, i + 1)
|
|
| _ -> (list, ibeg)
|
|
in
|
|
loop iend list (i + 1) ibeg
|
|
in
|
|
let list =
|
|
if String.unsafe_get s (len - 1) = ')' then
|
|
match String.rindex_opt s '(' with
|
|
| Some i when i < len - 2 ->
|
|
let j =
|
|
let rec loop i =
|
|
if i >= 0 && String.unsafe_get s i = ' ' then loop (i - 1)
|
|
else i + 1
|
|
in
|
|
loop (i - 1)
|
|
in
|
|
String.sub s (i + 1) (len - i - 2) :: loop j [] 0 0
|
|
| _ -> loop len [] 0 0
|
|
else loop len [] 0 0
|
|
in
|
|
((if inverted then List.rev list else list), sub)
|
|
|
|
(* TODO see how to merge these two fold_place_long *)
|
|
let fold_place_long_v6 inverted s =
|
|
let len = String.length s in
|
|
(* Trimm spaces after ',' and build reverse String.split_on_char ',' *)
|
|
let rec loop iend list i ibeg =
|
|
if i = iend then
|
|
if i > ibeg then String.sub s ibeg (i - ibeg) :: list else list
|
|
else
|
|
let list, ibeg =
|
|
match String.unsafe_get s i with
|
|
| ',' ->
|
|
let list =
|
|
if i > ibeg then String.sub s ibeg (i - ibeg) :: list else list
|
|
in
|
|
(list, i + 1)
|
|
| ' ' when i = ibeg -> (list, i + 1)
|
|
| _ -> (list, ibeg)
|
|
in
|
|
loop iend list (i + 1) ibeg
|
|
in
|
|
let list =
|
|
if String.unsafe_get s (len - 1) = ')' then
|
|
match String.rindex_opt s '(' with
|
|
| Some i when i < len - 2 ->
|
|
let j =
|
|
let rec loop i =
|
|
if i >= 0 && String.unsafe_get s i = ' ' then loop (i - 1)
|
|
else i + 1
|
|
in
|
|
loop (i - 1)
|
|
in
|
|
String.sub s (i + 1) (len - i - 2) :: loop j [] 0 0
|
|
| _ -> loop len [] 0 0
|
|
else loop len [] 0 0
|
|
in
|
|
if inverted then List.rev list else list
|
|
|
|
let fold_place_short inverted s =
|
|
if inverted then
|
|
match String.index_opt s ',' with Some i -> String.sub s 0 i | None -> s
|
|
else
|
|
let len = String.length s in
|
|
let default () =
|
|
let i =
|
|
match String.rindex_opt s ',' with
|
|
| Some i ->
|
|
let rec l i =
|
|
if i < len && String.unsafe_get s i = ' ' then l (i + 1) else i
|
|
in
|
|
l (i + 1)
|
|
| None -> 0
|
|
in
|
|
let i = if i = len then 0 else i in
|
|
String.sub s i (len - i)
|
|
in
|
|
if String.unsafe_get s (len - 1) = ')' then
|
|
match String.rindex_opt s '(' with
|
|
| Some i when i < len - 2 -> String.sub s (i + 1) (len - i - 2)
|
|
| _ -> default ()
|
|
else default ()
|
|
|
|
let places_to_string inverse pl =
|
|
(* TODO reverse ??*)
|
|
let pl = if inverse then List.rev pl else pl in
|
|
let rec loop acc first = function
|
|
| p :: l -> loop (p ^ (if first then "" else ", ") ^ acc) false l
|
|
| [] -> acc
|
|
in
|
|
loop "" true pl
|
|
|
|
exception List_too_long
|
|
|
|
let get_opt conf =
|
|
let to_url_param s =
|
|
if p_getenv conf.env s = Some "on" then Printf.sprintf "&%s=on" s else ""
|
|
in
|
|
let l =
|
|
List.map to_url_param
|
|
[
|
|
"bi";
|
|
"ba";
|
|
"de";
|
|
"bu";
|
|
"ma";
|
|
"f_sort";
|
|
"up";
|
|
"a_sort";
|
|
"lower";
|
|
"word";
|
|
"any";
|
|
]
|
|
in
|
|
String.concat "" l
|
|
|
|
let get_all conf base ~add_birth ~add_baptism ~add_death ~add_burial
|
|
~add_marriage (dummy_key : 'a) (dummy_value : 'c)
|
|
(fold_place : string -> 'a) (filter : 'a -> bool)
|
|
(mk_value : 'b option -> person -> 'b) (fn : 'b -> 'c) (max_length : int) :
|
|
('a * 'c) array =
|
|
let ht_size = 2048 in
|
|
(* FIXME: find the good heuristic *)
|
|
let ht : ('a, 'b) Hashtbl.t = Hashtbl.create ht_size in
|
|
let long = p_getenv conf.env "display" = Some "long" in
|
|
let ht_add istr p =
|
|
let key : 'a = sou base istr |> fold_place in
|
|
if filter key then
|
|
match Hashtbl.find_opt ht key with
|
|
| Some _ as prev -> Hashtbl.replace ht key (mk_value prev p)
|
|
| None ->
|
|
Hashtbl.add ht key (mk_value None p);
|
|
if Hashtbl.length ht > max_length && long then raise List_too_long
|
|
in
|
|
(if add_birth || add_death || add_baptism || add_burial then
|
|
let aux b fn p =
|
|
if b then
|
|
let x = fn p in
|
|
if not (is_empty_string x) then ht_add x p
|
|
in
|
|
Gwdb.Collection.iter
|
|
(fun i ->
|
|
let p = pget conf base i in
|
|
if authorized_age conf base p then (
|
|
aux add_birth get_birth_place p;
|
|
aux add_baptism get_baptism_place p;
|
|
aux add_death get_death_place p;
|
|
aux add_burial get_burial_place p))
|
|
(Gwdb.ipers base));
|
|
if add_marriage then
|
|
Gwdb.Collection.iter
|
|
(fun i ->
|
|
let fam = foi base i in
|
|
let pl_ma = get_marriage_place fam in
|
|
if not (is_empty_string pl_ma) then
|
|
let fath = pget conf base (get_father fam) in
|
|
let moth = pget conf base (get_mother fam) in
|
|
if authorized_age conf base fath && authorized_age conf base moth then (
|
|
ht_add pl_ma fath;
|
|
ht_add pl_ma moth))
|
|
(Gwdb.ifams base);
|
|
let len = Hashtbl.length ht in
|
|
let array = Array.make len (dummy_key, dummy_value) in
|
|
let i = ref 0 in
|
|
Hashtbl.iter
|
|
(fun k v ->
|
|
Array.unsafe_set array !i (k, fn v);
|
|
incr i)
|
|
ht;
|
|
array
|
|
|
|
let rec sort_place_utf8 k1 k2 =
|
|
match (k1, k2) with
|
|
| ([], sub1), ([], sub2) -> Gutil.alphabetic_order sub1 sub2
|
|
| _, ([], _) -> 1
|
|
| ([], _), _ -> -1
|
|
| (p1 :: pl1, sub1), (p2 :: pl2, sub2) ->
|
|
if Gutil.alphabetic_order p1 p2 = 0 then
|
|
sort_place_utf8 (pl1, sub1) (pl2, sub2)
|
|
else Gutil.alphabetic_order p1 p2
|
|
|
|
let clean_ps ps =
|
|
let len = String.length ps in
|
|
if ps.[0] = '(' && ps.[len - 1] = ')' then String.sub ps 1 (len - 2) else ps
|
|
|
|
let find_in conf x ini =
|
|
(* look at possibility to have ini=aaa, bbb or aaa (bbb) *)
|
|
let word = p_getenv conf.env "word" = Some "on" in
|
|
(* full words *)
|
|
let case = p_getenv conf.env "case" = Some "on" in
|
|
(* case sensitive *)
|
|
let any = p_getenv conf.env "any" = Some "on" in
|
|
(* anywhere in place list *)
|
|
let low s = if not case then Name.lower s else s in
|
|
let inil = String.split_on_char ',' ini in
|
|
let inil =
|
|
if List.length inil = 1 then
|
|
match String.index_opt ini '(' with
|
|
| Some index when index > 0 ->
|
|
[
|
|
String.sub ini 0 (index - 1);
|
|
String.sub ini index (String.length ini - index);
|
|
]
|
|
| Some _index -> [ ini ]
|
|
| None -> [ ini ]
|
|
else inil
|
|
in
|
|
List.fold_left
|
|
(fun acc ini ->
|
|
let ini = low ini in
|
|
acc
|
|
&&
|
|
if any || List.length inil > 1 then
|
|
List.fold_left
|
|
(fun r p ->
|
|
r || if word then low p = ini else Mutil.contains (low p) ini)
|
|
false x
|
|
else
|
|
match x with
|
|
| [] -> false
|
|
| x :: _ when word -> low x = ini
|
|
| x :: _ -> Mutil.contains (low x) ini)
|
|
true inil
|
|
|
|
let get_ip_list (snl : (string * iper list) list) =
|
|
List.map snd snl |> List.flatten |> List.sort_uniq compare
|
|
|
|
(* TODO clean-up pi (place) and qi (suburb??) *)
|
|
|
|
(** print the number of items in ip_list and a call to m=L for them **)
|
|
let print_ip_list conf places opt link_to_ind ipl =
|
|
let len = List.length ipl in
|
|
if len > max_rlm_nbr conf && link_to_ind then Output.printf conf "(%d)" len
|
|
else
|
|
let places = (Mutil.encode places :> string) in
|
|
let head =
|
|
Printf.sprintf " (<a href=\"%sm=L%s&k=%s&nb=%d&p0=%s"
|
|
(commd conf :> string)
|
|
opt places len places
|
|
in
|
|
let body =
|
|
let rec loop i acc = function
|
|
| [] -> acc
|
|
| ip :: ipl ->
|
|
loop (i + 1)
|
|
(Printf.sprintf "&i%d=%s" i (Gwdb.string_of_iper ip) ^ acc)
|
|
ipl
|
|
in
|
|
loop 0 "" ipl
|
|
in
|
|
let tail =
|
|
Printf.sprintf "\" title=\"%s\">%d</a>)"
|
|
(Utf8.capitalize (transl conf "summary book ascendants"))
|
|
(List.length ipl)
|
|
in
|
|
Output.print_sstring conf (head ^ body ^ tail)
|
|
|
|
(** print a call to m=PPS with a new k value *)
|
|
let pps_call conf opt long keep k places =
|
|
Printf.sprintf "<a href=\"%sm=PPS%s&display=%s&keep=%s&k=%s\">%s</a>"
|
|
(commd conf :> string)
|
|
opt
|
|
(if long then "long" else "short")
|
|
(string_of_int keep) k
|
|
(String.concat ", " places)
|
|
|
|
(* build ip list for all entries having same first element in places *)
|
|
let get_new_l l =
|
|
let new_l =
|
|
let rec loop prev ipl acc l =
|
|
match l with
|
|
| [] -> acc
|
|
| ((pl :: _pll, _), snl) :: l when pl = prev ->
|
|
loop prev (get_ip_list snl :: ipl) acc l
|
|
| ((pl :: _pll, _), _snl) :: l ->
|
|
loop pl [] ((prev, List.flatten ipl) :: acc) l
|
|
| ((_, _), _snl) :: l -> loop "" [] ((prev, List.flatten ipl) :: acc) l
|
|
in
|
|
loop "" [] [] l
|
|
in
|
|
new_l
|
|
|
|
(* conserve only keep elements of pll *)
|
|
let strip_pl keep pll =
|
|
if List.length pll <= keep then pll
|
|
else
|
|
let rec loop acc i pll =
|
|
match pll with
|
|
| [] -> List.rev acc
|
|
| _ when i > keep -> List.rev acc
|
|
| pl :: pll -> loop (pl :: acc) (i + 1) pll
|
|
in
|
|
loop [] 1 pll
|
|
|
|
let print_html_places_surnames_short conf _base _link_to_ind
|
|
(arry : ((string list * string) * (string * iper list) list) array) =
|
|
(* (sub_places_list * suburb) * (surname * ip_list) list *)
|
|
let long = p_getenv conf.env "display" = Some "long" in
|
|
let keep = match p_getint conf.env "keep" with Some t -> t | None -> 1 in
|
|
let a_sort = p_getenv conf.env "a_sort" = Some "on" in
|
|
let f_sort = p_getenv conf.env "f_sort" = Some "on" in
|
|
let up = p_getenv conf.env "up" = Some "on" in
|
|
let opt = get_opt conf in
|
|
Array.sort (fun (k1, _) (k2, _) -> sort_place_utf8 k1 k2) arry;
|
|
let l = Array.to_list arry in
|
|
(* build new list of (places, ipl) *)
|
|
(* accumulate snl according to keep *)
|
|
let new_l =
|
|
let rec loop prev_pl acc_snl acc_l = function
|
|
| ((pl, _sub), snl) :: l when prev_pl = strip_pl keep pl ->
|
|
loop (strip_pl keep pl) (get_ip_list snl :: acc_snl) acc_l l
|
|
| ((pl, _sub), snl) :: l when acc_snl <> [] ->
|
|
let acc_snl = List.sort_uniq compare (List.flatten acc_snl) in
|
|
loop (strip_pl keep pl)
|
|
[ get_ip_list snl ]
|
|
((prev_pl, acc_snl) :: acc_l)
|
|
l
|
|
| ((pl, _sub), snl) :: l ->
|
|
loop (strip_pl keep pl) [ get_ip_list snl ] acc_l l
|
|
| [] ->
|
|
let acc_snl = List.sort_uniq compare (List.flatten acc_snl) in
|
|
(prev_pl, acc_snl) :: acc_l
|
|
in
|
|
loop [] [] [] l
|
|
in
|
|
(* sort *)
|
|
let new_l =
|
|
if a_sort then
|
|
List.sort
|
|
(fun (pl1, _) (pl2, _) -> sort_place_utf8 (pl1, "") (pl2, ""))
|
|
new_l
|
|
else
|
|
List.sort
|
|
(fun (pl1, _) (pl2, _) -> sort_place_utf8 (pl2, "") (pl1, ""))
|
|
new_l
|
|
in
|
|
let new_l =
|
|
if f_sort then
|
|
List.sort
|
|
(fun (_, ipl1) (_, ipl2) ->
|
|
if up then List.length ipl1 - List.length ipl2
|
|
else List.length ipl2 - List.length ipl1)
|
|
new_l
|
|
else new_l
|
|
in
|
|
(* accumulate snl entries with same pl value *)
|
|
let new_l =
|
|
let rec loop prev acc_snl acc_l new_l =
|
|
match (new_l, prev) with
|
|
| (pl, snl) :: l, prev when prev = strip_pl keep pl ->
|
|
loop pl ((pl, snl) :: acc_snl) acc_l l
|
|
| (pl, snl) :: l, prev when prev <> strip_pl keep pl ->
|
|
loop pl
|
|
[ (pl, snl) ]
|
|
(if acc_snl <> [] then acc_snl :: acc_l else acc_l)
|
|
l
|
|
| (pl, snl) :: l, _ -> loop pl [] ([ (pl, snl) ] :: acc_l) l
|
|
| [], _ -> if acc_snl <> [] then acc_snl :: acc_l else acc_l
|
|
in
|
|
loop [ "" ] [] [] new_l
|
|
in
|
|
let print_one_entry l =
|
|
let len = List.fold_left (fun acc (_, ipl) -> acc + List.length ipl) 0 l in
|
|
let rec loop0 l =
|
|
match l with
|
|
| [] -> ()
|
|
| (pl, ipl) :: l ->
|
|
let str = places_to_string true pl in
|
|
let str2 = (Mutil.encode str :> string) in
|
|
Output.printf conf
|
|
"<a href=\"%sm=PPS%s&display=%s&keep=%s&k=%s\">%s</a>"
|
|
(commd conf :> string)
|
|
opt
|
|
(if long then "long" else "short")
|
|
(string_of_int (keep + 1))
|
|
str2 str;
|
|
if len < max_rlm_nbr conf then (
|
|
Output.printf conf " (<a href=\"%sm=L%s&k=%s&nb=%d"
|
|
(commd conf :> string)
|
|
opt str2 len;
|
|
let rec loop1 i = function
|
|
| [] -> ()
|
|
| (pl, ipl) :: l ->
|
|
let rec loop2 i = function
|
|
| [] -> loop1 i l
|
|
| ip :: ipl ->
|
|
Output.printf conf "&i%d=%s%s" i
|
|
(Gwdb.string_of_iper ip)
|
|
(Printf.sprintf "&p%d=%s" i
|
|
(places_to_string false pl));
|
|
loop2 (i + 1) ipl
|
|
in
|
|
loop2 i ipl
|
|
in
|
|
loop1 0 ((pl, ipl) :: l);
|
|
Output.printf conf "\" title=\"%s\">%d</a>)"
|
|
(Utf8.capitalize (transl conf "summary book ascendants"))
|
|
len)
|
|
else Output.printf conf " (%d)" len;
|
|
loop0 l
|
|
in
|
|
loop0 l
|
|
in
|
|
let rec loop first = function
|
|
| l1 :: l ->
|
|
Output.print_sstring conf (if first then "" else ", ");
|
|
print_one_entry l1;
|
|
loop false l
|
|
| [] -> ()
|
|
in
|
|
loop true new_l;
|
|
Output.print_sstring conf "<p>"
|
|
|
|
let print_html_places_surnames_long conf base link_to_ind
|
|
(arry : ((string list * string) * (string * iper list) list) array) =
|
|
(* (sub_places_list * suburb) * (surname * ip_list) list *)
|
|
let k =
|
|
(Mutil.encode (match p_getenv conf.env "k" with Some s -> s | _ -> "")
|
|
:> string)
|
|
in
|
|
let keep = match p_getint conf.env "keep" with Some t -> t | None -> 1 in
|
|
let a_sort = p_getenv conf.env "a_sort" = Some "on" in
|
|
let f_sort = p_getenv conf.env "f_sort" = Some "on" in
|
|
let up = p_getenv conf.env "up" = Some "on" in
|
|
let opt = get_opt conf in
|
|
Array.sort (fun (k1, _) (k2, _) -> sort_place_utf8 k1 k2) arry;
|
|
let l = Array.to_list arry in
|
|
(* sort global list according to a_sort, f_sort *)
|
|
let l =
|
|
if f_sort then
|
|
List.sort
|
|
(fun (_, ipl1) (_, ipl2) ->
|
|
if up then List.length ipl1 - List.length ipl2
|
|
else List.length ipl2 - List.length ipl1)
|
|
l
|
|
else if a_sort then
|
|
List.sort (fun (p1, _) (p2, _) -> sort_place_utf8 p2 p1) l
|
|
else l
|
|
in
|
|
let print_sn (sn, ips) (pl, _sub) =
|
|
(* Warn : do same sort_uniq in short mode *)
|
|
let ips = List.sort_uniq compare ips in
|
|
let places = places_to_string true pl in
|
|
if link_to_ind then (
|
|
match ips with
|
|
| [ ip ] ->
|
|
Output.printf conf "<a href=\"%s" (commd conf :> string);
|
|
Output.print_string conf (acces conf base @@ pget conf base @@ ip);
|
|
Output.printf conf "\" title=\"%s\">%s</a>"
|
|
(sou base (get_first_name (poi base ip)))
|
|
sn
|
|
| _ ->
|
|
Output.printf conf "<a href=\"%s" (commd conf :> string);
|
|
Output.printf conf "m=N&v=%s" (sn :> string);
|
|
Output.printf conf "\">%s</a>" sn)
|
|
else Output.printf conf "%s" (sn :> string);
|
|
print_ip_list conf places opt link_to_ind ips
|
|
in
|
|
let print_sn_list (pl, sub) (snl : (string * iper list) list) =
|
|
Output.printf conf "<li>%s\n" (if sub <> "" then sub else "");
|
|
let snl =
|
|
(* sort surname list according to a_sort, f_sort *)
|
|
if f_sort then
|
|
List.sort
|
|
(fun (_, ipl1) (_, ipl2) ->
|
|
if up then List.length ipl1 - List.length ipl2
|
|
else List.length ipl2 - List.length ipl1)
|
|
snl
|
|
else
|
|
List.sort
|
|
(fun (p1, _) (p2, _) ->
|
|
if a_sort then Gutil.alphabetic_order p2 p1
|
|
else Gutil.alphabetic_order p1 p2)
|
|
snl
|
|
in
|
|
Mutil.list_iter_first
|
|
(fun first x ->
|
|
if not first then Output.printf conf ",\n";
|
|
print_sn x (pl, sub))
|
|
snl;
|
|
Output.printf conf "\n";
|
|
Output.print_sstring conf "</li>\n"
|
|
in
|
|
|
|
let rec loop prev = function
|
|
| ((pl, sub), snl) :: l ->
|
|
let rec loop1 prev (pl, sub) =
|
|
match (prev, pl) with
|
|
| [], l2 ->
|
|
List.iter
|
|
(fun x ->
|
|
Output.printf conf "<li>%s<ul>\n"
|
|
(pps_call conf opt true keep k [ x ]))
|
|
l2
|
|
| x1 :: l1, x2 :: l2 ->
|
|
if x1 = x2 then loop1 l1 (l2, sub)
|
|
else (
|
|
List.iter
|
|
(fun _ -> Output.print_sstring conf "</ul></li>\n")
|
|
(x1 :: l1);
|
|
loop1 [] (x2 :: l2, sub))
|
|
| _ -> Output.print_sstring conf "</ul></li>\n"
|
|
(* FIXME was assert false!! *)
|
|
in
|
|
loop1 prev (pl, sub);
|
|
print_sn_list (pl, sub) snl;
|
|
loop pl l
|
|
| [] -> List.iter (fun _ -> Output.print_sstring conf "</ul></li>\n") prev
|
|
in
|
|
Output.print_sstring conf "<ul>\n";
|
|
loop [] l;
|
|
Output.print_sstring conf "</ul>\n"
|
|
|
|
let print_all_places_surnames_aux conf base _ini ~add_birth ~add_baptism
|
|
~add_death ~add_burial ~add_marriage max_length short filter =
|
|
let inverted =
|
|
try List.assoc "places_inverted" conf.base_env = "yes"
|
|
with Not_found -> false
|
|
in
|
|
let arry =
|
|
get_all conf base ~add_birth ~add_baptism ~add_death ~add_burial
|
|
~add_marriage ([], "") [] (fold_place_long inverted) filter
|
|
(fun prev p ->
|
|
(* add one ip to a list flagged by surname *)
|
|
let value = (get_surname p, get_iper p) in
|
|
match prev with Some l -> value :: l | None -> [ value ])
|
|
(fun v ->
|
|
let v = List.sort (fun (a, _) (b, _) -> compare a b) v in
|
|
let rec loop acc l =
|
|
match (l, acc) with
|
|
| [], _ -> acc
|
|
| (sn, iper) :: tl_list, (sn', iper_list) :: tl_acc
|
|
when sou base sn = sn' ->
|
|
loop ((sn', iper :: iper_list) :: tl_acc) tl_list
|
|
| (sn, iper) :: tl_list, _ ->
|
|
loop ((sou base sn, [ iper ]) :: acc) tl_list
|
|
in
|
|
loop [] v)
|
|
max_length
|
|
in
|
|
Array.sort (fun (k1, _) (k2, _) -> sort_place_utf8 k1 k2) arry;
|
|
let title _ =
|
|
Output.printf conf "%s / %s"
|
|
(Utf8.capitalize (transl_nth conf "place/places" 0))
|
|
(Utf8.capitalize (transl_nth conf "surname/surnames" 0))
|
|
in
|
|
let opt = get_opt conf in
|
|
let long = p_getenv conf.env "display" = Some "long" in
|
|
let keep = match p_getint conf.env "keep" with Some t -> t | None -> 1 in
|
|
Hutil.header conf title;
|
|
Hutil.print_link_to_welcome conf true;
|
|
Hutil.interp_no_header conf "buttons_places"
|
|
{
|
|
Templ.eval_var = (fun _ -> raise Not_found);
|
|
Templ.eval_transl = (fun _ -> Templ.eval_transl conf);
|
|
Templ.eval_predefined_apply = (fun _ -> raise Not_found);
|
|
Templ.get_vother;
|
|
Templ.set_vother;
|
|
Templ.print_foreach = (fun _ -> raise Not_found);
|
|
}
|
|
[]
|
|
(Gwdb.empty_person base Gwdb.dummy_iper);
|
|
Output.printf conf "<form method=\"get\" action=\"%s\">\n" conf.command;
|
|
let link_to_ind =
|
|
match List.assoc_opt "place_surname_link_to_ind" conf.base_env with
|
|
| Some "yes" -> true
|
|
| _ -> false
|
|
in
|
|
let t =
|
|
if short then
|
|
Printf.sprintf "%s" (Utf8.capitalize (transl conf "v7 list too long"))
|
|
else ""
|
|
in
|
|
let href =
|
|
Printf.sprintf "href=\"%sm=PPS%s&display=%s&keep=%s%s\" title=\"%s\""
|
|
(commd conf :> string)
|
|
opt
|
|
(if long then "short" else "long")
|
|
(string_of_int keep)
|
|
(match p_getenv conf.env "k" with
|
|
| Some ini -> "&k=" ^ (Mutil.encode ini :> string)
|
|
| None -> "")
|
|
t
|
|
in
|
|
Output.printf conf "<p>\n<a %s>%s</a>" href
|
|
(Utf8.capitalize
|
|
(transl conf (if long then "short display" else "long display")));
|
|
if short then Output.printf conf " (%s)\n" t;
|
|
Output.printf conf "<p>\n";
|
|
if arry <> [||] then
|
|
if long then print_html_places_surnames_long conf base link_to_ind arry
|
|
else print_html_places_surnames_short conf base link_to_ind arry;
|
|
Output.printf conf "</form>\n";
|
|
Hutil.trailer conf
|
|
|
|
let print_all_places_surnames conf base =
|
|
let add_marriage = p_getenv conf.env "ma" = Some "on" in
|
|
let add_birth = p_getenv conf.env "bi" = Some "on" in
|
|
let add_baptism = p_getenv conf.env "ba" = Some "on" in
|
|
let add_death = p_getenv conf.env "de" = Some "on" in
|
|
let add_burial = p_getenv conf.env "bu" = Some "on" in
|
|
let lim =
|
|
try int_of_string @@ List.assoc "short_place_threshold" conf.base_env
|
|
with _ -> 500
|
|
in
|
|
let ini, filter =
|
|
match p_getenv conf.env "k" with
|
|
| Some ini ->
|
|
( ini,
|
|
if ini = "" then fun _ -> true else fun (x, _) -> find_in conf x ini
|
|
)
|
|
| None -> ("", fun _ -> true)
|
|
in
|
|
try
|
|
print_all_places_surnames_aux conf base ini ~add_birth ~add_baptism
|
|
~add_death ~add_burial ~add_marriage lim false filter
|
|
with List_too_long ->
|
|
let conf =
|
|
{
|
|
conf with
|
|
env =
|
|
("display", Adef.encoded "short")
|
|
:: List.remove_assoc "display" conf.env;
|
|
}
|
|
in
|
|
print_all_places_surnames_aux conf base ini ~add_birth ~add_baptism
|
|
~add_death ~add_burial ~add_marriage lim true filter
|
|
|
|
let print_list conf _base =
|
|
Hutil.interp conf "list"
|
|
{
|
|
Templ.eval_var = (fun _ -> raise Not_found);
|
|
Templ.eval_transl = (fun _ -> Templ.eval_transl conf);
|
|
Templ.eval_predefined_apply = (fun _ -> raise Not_found);
|
|
Templ.get_vother;
|
|
Templ.set_vother;
|
|
Templ.print_foreach = (fun _ -> raise Not_found);
|
|
}
|
|
[] ()
|