Initial comit - Clone
This commit is contained in:
9
plugins/cgl/dune
Normal file
9
plugins/cgl/dune
Normal file
@ -0,0 +1,9 @@
|
||||
(executable
|
||||
(name plugin_cgl)
|
||||
(libraries geneweb geneweb.gwd_lib geneweb.wserver)
|
||||
(modes
|
||||
(native plugin)))
|
||||
|
||||
(alias
|
||||
(name plugin)
|
||||
(deps plugin_cgl.cmxs))
|
||||
39
plugins/cgl/plugin_cgl.ml
Normal file
39
plugins/cgl/plugin_cgl.ml
Normal file
@ -0,0 +1,39 @@
|
||||
open Geneweb
|
||||
open Config
|
||||
|
||||
let ns = "cgl"
|
||||
|
||||
let () =
|
||||
Gwd_lib.GwdPlugin.register_se ~ns @@ fun _assets conf _base ->
|
||||
if Util.p_getenv conf.env "cgl" = Some "on" then
|
||||
let buffer_status = ref None in
|
||||
let buffer_headers = ref [] in
|
||||
let buffer_body = Buffer.create 1023 in
|
||||
let previous_status = conf.output_conf.status in
|
||||
let previous_header = conf.output_conf.header in
|
||||
let previous_body = conf.output_conf.body in
|
||||
let previous_flush = conf.output_conf.flush in
|
||||
let status s = buffer_status := Some s in
|
||||
let header s = buffer_headers := s :: !buffer_headers in
|
||||
let body s = Buffer.add_string buffer_body s in
|
||||
let flush () =
|
||||
conf.output_conf <-
|
||||
{
|
||||
status = previous_status;
|
||||
header = previous_header;
|
||||
body = previous_body;
|
||||
flush = previous_flush;
|
||||
};
|
||||
(match !buffer_status with Some s -> Output.status conf s | None -> ());
|
||||
List.iter (Output.header conf "%s") (List.rev !buffer_headers);
|
||||
let open Markup in
|
||||
buffer buffer_body |> parse_html |> signals
|
||||
|> map (function
|
||||
| `Start_element (("http://www.w3.org/1999/xhtml", "a"), _) ->
|
||||
`Start_element (("http://www.w3.org/1999/xhtml", "span"), [])
|
||||
| x -> x)
|
||||
|> write_html |> to_string |> Output.print_sstring conf;
|
||||
Output.flush conf;
|
||||
Buffer.reset buffer_body
|
||||
in
|
||||
conf.output_conf <- { status; header; body; flush }
|
||||
21
plugins/export/dune
Normal file
21
plugins/export/dune
Normal file
@ -0,0 +1,21 @@
|
||||
(executable
|
||||
(name plugin_export)
|
||||
(libraries
|
||||
geneweb
|
||||
geneweb.gwb2ged_lib
|
||||
geneweb.gwd_lib
|
||||
geneweb.gwexport_lib
|
||||
geneweb.gwu_lib
|
||||
geneweb.wserver)
|
||||
(embed_in_plugin_libraries
|
||||
geneweb.gwexport_lib
|
||||
geneweb.gwu_lib
|
||||
geneweb.gwb2ged_lib)
|
||||
(flags
|
||||
(:standard -w -40-27))
|
||||
(modes
|
||||
(native plugin)))
|
||||
|
||||
(alias
|
||||
(name plugin)
|
||||
(deps plugin_export.cmxs))
|
||||
153
plugins/export/plugin_export.ml
Normal file
153
plugins/export/plugin_export.ml
Normal file
@ -0,0 +1,153 @@
|
||||
open Geneweb
|
||||
open Config
|
||||
open Gwdb
|
||||
|
||||
let ns = "export"
|
||||
|
||||
module IPS = Set.Make (struct
|
||||
type t = Gwdb.iper
|
||||
|
||||
let compare = compare
|
||||
end)
|
||||
|
||||
module IFS = Set.Make (struct
|
||||
type t = Gwdb.ifam
|
||||
|
||||
let compare = compare
|
||||
end)
|
||||
|
||||
let w_lock =
|
||||
Gwd_lib.Request.w_lock ~onerror:(fun conf _ -> Update.error_locked conf)
|
||||
|
||||
let w_base =
|
||||
Gwd_lib.Request.w_base ~none:(fun conf ->
|
||||
Hutil.incorrect_request conf;
|
||||
true)
|
||||
|
||||
let getenv var env = List.assoc var env |> Mutil.decode
|
||||
let getenv_opt var env = List.assoc_opt var env |> Option.map Mutil.decode
|
||||
|
||||
let export conf base =
|
||||
assert conf.wizard;
|
||||
match
|
||||
match getenv_opt "output" conf.env with
|
||||
| Some "GED" -> Some `ged
|
||||
| Some "GW" -> Some `gw
|
||||
| _ -> None
|
||||
with
|
||||
| None -> false
|
||||
| Some output ->
|
||||
Mutil.verbose := false;
|
||||
let find_iper i =
|
||||
getenv ("i" ^ string_of_int i) conf.env |> Gwdb.iper_of_string
|
||||
in
|
||||
let find_npoc i =
|
||||
let n = getenv ("n" ^ string_of_int i) conf.env in
|
||||
let p = getenv ("p" ^ string_of_int i) conf.env in
|
||||
let oc =
|
||||
match getenv_opt ("oc" ^ string_of_int i) conf.env with
|
||||
| None -> 0
|
||||
| Some i -> int_of_string i
|
||||
in
|
||||
match Gwdb.person_of_key base p n oc with
|
||||
| None -> raise Not_found
|
||||
| Some i -> i
|
||||
in
|
||||
let find_p i = try find_iper i with Not_found -> find_npoc i in
|
||||
let rec loop acc cnt =
|
||||
try loop (IPS.add (find_p cnt) acc) (cnt + 1) with Not_found -> acc
|
||||
in
|
||||
let ini = loop IPS.empty 1 in
|
||||
let fname =
|
||||
Gwdb.bname base ^ match output with `ged -> ".ged" | `gw -> ".gw"
|
||||
in
|
||||
let ipers =
|
||||
if getenv_opt "spouses" conf.env = Some "on" then
|
||||
IPS.fold
|
||||
(fun iper acc ->
|
||||
Array.fold_left
|
||||
(fun acc ifam ->
|
||||
IPS.add (Gutil.spouse iper @@ foi base ifam) acc)
|
||||
acc
|
||||
(get_family (poi base iper)))
|
||||
ini ini
|
||||
else ini
|
||||
in
|
||||
let ipers =
|
||||
if getenv_opt "parents" conf.env = Some "on" then
|
||||
IPS.fold
|
||||
(fun iper acc ->
|
||||
match get_parents (poi base iper) with
|
||||
| None -> acc
|
||||
| Some ifam ->
|
||||
let fam = foi base ifam in
|
||||
IPS.add (get_father fam) (IPS.add (get_mother fam) acc))
|
||||
ini ipers
|
||||
else ipers
|
||||
in
|
||||
let ipers =
|
||||
if getenv_opt "children" conf.env = Some "on" then
|
||||
IPS.fold
|
||||
(fun iper acc ->
|
||||
Array.fold_left
|
||||
(fun acc ifam ->
|
||||
Array.fold_left
|
||||
(fun acc iper -> IPS.add iper acc)
|
||||
acc
|
||||
(get_children @@ foi base ifam))
|
||||
acc
|
||||
(get_family (poi base iper)))
|
||||
ini ipers
|
||||
else ipers
|
||||
in
|
||||
let ifams =
|
||||
IPS.fold
|
||||
(fun iper acc ->
|
||||
Array.fold_left
|
||||
(fun acc ifam ->
|
||||
if
|
||||
IFS.mem ifam acc
|
||||
|| not (IPS.mem (Gutil.spouse iper @@ foi base ifam) ipers)
|
||||
then acc
|
||||
else IFS.add ifam acc)
|
||||
acc
|
||||
(get_family (poi base iper)))
|
||||
ipers IFS.empty
|
||||
in
|
||||
let no_notes =
|
||||
match getenv_opt "notes" conf.env with
|
||||
| None -> `none
|
||||
| Some "nn" -> `nn
|
||||
| Some "nnn" -> `nnn
|
||||
| Some _ -> `none
|
||||
in
|
||||
let source = getenv_opt "source" conf.env in
|
||||
let isolated = getenv_opt "isolated" conf.env <> Some "off" in
|
||||
let opts =
|
||||
{
|
||||
Gwexport.default_opts with
|
||||
oc = (fname, Output.print_sstring conf, Wserver.close_connection);
|
||||
no_notes;
|
||||
no_picture = getenv_opt "pictures" conf.env = Some "off";
|
||||
source;
|
||||
base = Some (Gwdb.bname base, base);
|
||||
}
|
||||
in
|
||||
let select = ((fun i -> IPS.mem i ipers), fun i -> IFS.mem i ifams) in
|
||||
Wserver.http Def.OK;
|
||||
Wserver.header "Content-type: text/plain";
|
||||
Wserver.header
|
||||
(Printf.sprintf "Content-disposition: attachment; filename=\"%s\"" fname);
|
||||
(match output with
|
||||
| `ged -> Gwb2gedLib.gwb2ged false opts select
|
||||
| `gw ->
|
||||
GwuLib.prepare_free_occ ~select:(fst select) base;
|
||||
Output.print_sstring conf "encoding: utf-8\n";
|
||||
Output.print_sstring conf "gwplus\n\n";
|
||||
GwuLib.gwu opts isolated base "" "" (Hashtbl.create 0) select);
|
||||
Wserver.wflush ();
|
||||
true
|
||||
|
||||
let () =
|
||||
Gwd_lib.GwdPlugin.register ~ns
|
||||
[ ("EXPORT", fun _assets -> w_lock @@ w_base @@ export) ]
|
||||
1
plugins/fixbase/META
Normal file
1
plugins/fixbase/META
Normal file
@ -0,0 +1 @@
|
||||
depends:lib_show
|
||||
124
plugins/fixbase/assets/lex/lexicon.txt
Normal file
124
plugins/fixbase/assets/lex/lexicon.txt
Normal file
@ -0,0 +1,124 @@
|
||||
plugin_fixbase_FIXBASE
|
||||
co: Avventata di i dati deteriurati
|
||||
en: Detect corrupted data
|
||||
fr: Détection des données corrompues
|
||||
|
||||
plugin_fixbase_FIXBASE_OK
|
||||
co: Currezzione di i dati alterati
|
||||
en: Fix corrupted data
|
||||
fr: Correction des données corrompues
|
||||
|
||||
plugin_fixbase_description
|
||||
co: St’attrezzu vi pò permette di currege certi dati in una basa. Una validazione di i cambiamenti pruposti vi serà dumandata prima d’appiecalli nant’à a basa.
|
||||
en: This tool (may) allow you to fix corrupted data in a base. You will be asked to review proposed changes before actually applying them to the base.
|
||||
fr: Cet outil permet de corriger certaines données corrompues. Une validation des changements proposés vous sera demandée avant d'appliquer les correctifs à la base.
|
||||
|
||||
plugin_fixbase_f_children
|
||||
co: Aghjunghje i genitori assente à quelli arregistrati cum’è zitella(u) d’una famiglia.
|
||||
en: Add missing parents to ones recorded as child of a family.
|
||||
fr: Ajoute les parents manquants à quelqu'un enregistré comme enfant d'une famille.
|
||||
|
||||
plugin_fixbase_f_parents
|
||||
co: Aghjunghje l’unioni assente à quelli arregistrati cum’è genitore d’una famiglia.
|
||||
en: Add missing unions to ones recorded as parent of a family.
|
||||
fr: Ajoute les unions manquantes aux individus enregistré comme parent d'une famille.
|
||||
|
||||
plugin_fixbase_fevents_witnesses
|
||||
co: Aghjunghje e relazioni assente truvate in l’evenimenti famigliali.
|
||||
en: Add missing related from family events.
|
||||
fr: Ajoute les relations manquantes trouvées dans les événements familiaux.
|
||||
|
||||
plugin_fixbase_invalid_utf8
|
||||
co: Currege i testi malcudificati.
|
||||
en: Fix wrong UTF8 encoding.
|
||||
fr: Corrige les textes mal encodés.
|
||||
|
||||
plugin_fixbase_marriage_divorce
|
||||
co: Currege i campi matrimoniu è divorziu secondu à l’evenimenti famigliali.
|
||||
en: Fix marriage and divorce field based on family events.
|
||||
fr: Corrige les champs mariage et divorce en se basant sur les événements familiaux.
|
||||
|
||||
plugin_fixbase_missing_spouses
|
||||
co: Ristureghja e persone viote squassate ma sempre presente in un’unione.
|
||||
en: Restore empty persons deleted but still present in an union.
|
||||
fr: Restaure les personnes vides supprimées mais toujours renseignées dans une union.
|
||||
|
||||
plugin_fixbase_ok_apply
|
||||
co: Appiecà sti cambiamenti.
|
||||
en: Apply these changes.
|
||||
fr: Appliquer ces modifications.
|
||||
|
||||
plugin_fixbase_ok_base_changed
|
||||
co: A basa hè stata mudificata dapoi l’esecuzione di l’analisa.
|
||||
en: Base changed after the scanner was ran.
|
||||
fr: La base à été modifiée depuis le scan.
|
||||
|
||||
plugin_fixbase_ok_commit_patches
|
||||
co: Mudificazioni appiecate.
|
||||
en: Changed applied.
|
||||
fr: Modifications effectuées.
|
||||
|
||||
plugin_fixbase_ok_nothing
|
||||
co: Ùn ci hè nunda à currege per l’ozzioni scelte.
|
||||
en: There is nothing to fix, for chosen options.
|
||||
fr: Pas d'erreur à corriger pour les options choisies.
|
||||
|
||||
plugin_fixbase_ok_refresh
|
||||
co: Attualizà torna.
|
||||
en: Refresh.
|
||||
fr: Réactualiser.
|
||||
|
||||
plugin_fixbase_ok_return
|
||||
co: Ritornu à u furmulariu.
|
||||
en: Go back to the form.
|
||||
fr: Retourner au formulaire.
|
||||
|
||||
plugin_fixbase_ok_tstab
|
||||
co: Squassatura di i schedarii d’impiatta sosa.
|
||||
en: Delete sosa cache files.
|
||||
fr: Suppression des fichiers de cache sosa.
|
||||
|
||||
plugin_fixbase_p_NBDS
|
||||
co: Currege i campi nascita, battesimu, morte è sepultura secondu à l’evenimenti persunali.
|
||||
en: Fix birth, baptism, death and burial fields according to what is present in personnal events.
|
||||
fr: Corrige les champs naissance, baptême, décès et sépulture en se basant sur les événement personnels.
|
||||
|
||||
plugin_fixbase_p_families
|
||||
co: Caccia i duppioni in l’unioni d’una listessa persona.
|
||||
en: Remove same unions used more than once for the same person.
|
||||
fr: Supprime les doublons dans les unions d'une personne.
|
||||
|
||||
plugin_fixbase_p_key
|
||||
co: Currege e chjavi in doppiu mudifichendu u numeru d’occurenza.
|
||||
en: Fix duplicate keys by changing the number.
|
||||
fr: Corrige les clés en double en modifiant le numéro d'occurence.
|
||||
|
||||
plugin_fixbase_p_parents
|
||||
co: Caccia i genitori o aghjunghje un(a) zitellu(a).
|
||||
en: Remove parents or add child.
|
||||
fr: Supprime les parents ou ajoute un enfant.
|
||||
|
||||
plugin_fixbase_password_missing
|
||||
co: Parolla d’intesa assente.
|
||||
en: Missing password.
|
||||
fr: Mot de passe nécessaire.
|
||||
|
||||
plugin_fixbase_password_submit
|
||||
co: Sottumette
|
||||
en: Submit
|
||||
fr: Soumettre
|
||||
|
||||
plugin_fixbase_pevents_witnesses
|
||||
co: Aghjunghje e relazioni assente truvate in l’evenimenti persunali.
|
||||
en: Add missing related from personnal events.
|
||||
fr: Ajoute les relations manquantes trouvées dans les événements personnels.
|
||||
|
||||
plugin_fixbase_submit
|
||||
co: Fà a currezzione
|
||||
en: Fix it
|
||||
fr: Lancer la correction
|
||||
|
||||
plugin_fixbase_tstab
|
||||
co: Caccia certi schedarii d’impiatta impiegati per calculà u numeru sosa.
|
||||
en: Remove some cache files involved in sosa computing.
|
||||
fr: Supprime les fichiers de cache utilisés pour calculer le numéro sosa.
|
||||
19
plugins/fixbase/dune
Normal file
19
plugins/fixbase/dune
Normal file
@ -0,0 +1,19 @@
|
||||
(alias
|
||||
(name plugin)
|
||||
(deps
|
||||
(source_tree assets)
|
||||
plugin_fixbase.cmxs))
|
||||
|
||||
(executable
|
||||
(name plugin_fixbase)
|
||||
(libraries geneweb.gwd_lib geneweb_def_show)
|
||||
(preprocess
|
||||
(pps ppx_deriving.show))
|
||||
(flags -linkall)
|
||||
(modes
|
||||
(native plugin))
|
||||
(modules plugin_fixbase))
|
||||
|
||||
(alias
|
||||
(name plugin)
|
||||
(deps plugin_fixbase.cmxs))
|
||||
440
plugins/fixbase/plugin_fixbase.ml
Normal file
440
plugins/fixbase/plugin_fixbase.ml
Normal file
@ -0,0 +1,440 @@
|
||||
open Geneweb
|
||||
open Config
|
||||
open Gwdb
|
||||
|
||||
let arg_f_parents = "f_parents"
|
||||
let arg_f_children = "f_children"
|
||||
let arg_p_parents = "p_parents"
|
||||
let arg_p_NBDS = "p_NBDS"
|
||||
let arg_p_families = "p_families"
|
||||
let arg_pevents_witnesses = "pevents_witnesses"
|
||||
let arg_fevents_witnesses = "fevents_witnesses"
|
||||
let arg_marriage_divorce = "marriage_divorce"
|
||||
let arg_missing_spouses = "missing_spouses"
|
||||
let arg_invalid_utf8 = "invalid_utf8"
|
||||
let arg_p_key = "p_key"
|
||||
let arg_tstab = "tstab"
|
||||
let arg_password = "password"
|
||||
|
||||
module UI = struct
|
||||
let enabled conf s = (List.assoc_opt s conf.env :> string option) = Some "on"
|
||||
|
||||
let print_arg conf
|
||||
((name, kind, doc) :
|
||||
Adef.encoded_string * [> `Arg_Set | `Arg_String ] * Adef.safe_string) =
|
||||
match kind with
|
||||
| `Arg_Set ->
|
||||
Output.print_sstring conf {|<p><label><input type="checkbox" name="|};
|
||||
Output.print_string conf name;
|
||||
Output.print_sstring conf {|" value="on"> |};
|
||||
Output.print_string conf doc;
|
||||
Output.print_sstring conf {|</label></p>|}
|
||||
| `Arg_String ->
|
||||
Output.print_sstring conf {|<p><label><input type="type" name="|};
|
||||
Output.print_string conf name;
|
||||
Output.print_sstring conf {|"> |};
|
||||
Output.print_string conf doc;
|
||||
Output.print_sstring conf {|</label></p>|}
|
||||
|
||||
let form conf (m : Adef.encoded_string) (submit : Adef.safe_string) args =
|
||||
Output.print_sstring conf {|<form action="|};
|
||||
Output.print_string conf (Util.commd conf);
|
||||
Output.print_sstring conf {|" method="GET">|};
|
||||
Output.print_sstring conf {|<input type="hidden" name="m" value="|};
|
||||
Output.print_string conf m;
|
||||
Output.print_sstring conf {|">|};
|
||||
(match List.assoc_opt arg_password conf.env with
|
||||
| Some x ->
|
||||
Output.print_sstring conf
|
||||
{|<input type="hidden" name="password" value="|};
|
||||
Output.print_string conf x;
|
||||
Output.print_sstring conf {|">|}
|
||||
| None -> ());
|
||||
List.iter (print_arg conf) args;
|
||||
Output.print_sstring conf {|<input type="submit" value="|};
|
||||
Output.print_string conf submit;
|
||||
Output.print_sstring conf {|">|};
|
||||
Output.print_sstring conf {|</form>|}
|
||||
end
|
||||
|
||||
let opt_password =
|
||||
match Sys.getenv_opt "GW_PLUGIN_FIXBASE_PASSWORD" with
|
||||
| Some "" | None -> None
|
||||
| Some x -> Some (Mutil.encode x)
|
||||
|
||||
let opt_manitou =
|
||||
match Sys.getenv_opt "GW_PLUGIN_FIXBASE_ONLY_MANITOU" with
|
||||
| Some ("on" | "ON" | "y" | "Y" | "1") -> true
|
||||
| _ -> false
|
||||
|
||||
let missing_password conf =
|
||||
let args =
|
||||
[
|
||||
( Mutil.encode arg_password,
|
||||
`Arg_String,
|
||||
Util.transl conf "plugin_fixbase_password_missing" |> Adef.safe );
|
||||
]
|
||||
in
|
||||
UI.form conf (List.assoc "m" conf.env)
|
||||
(Util.transl conf "plugin_fixbase_password_submit" |> Adef.safe)
|
||||
args
|
||||
|
||||
let wrap conf title fn =
|
||||
!GWPARAM.wrap_output conf title @@ fun () ->
|
||||
if opt_password = List.assoc_opt arg_password conf.env then fn ()
|
||||
else missing_password conf
|
||||
|
||||
let fixbase conf _base =
|
||||
wrap conf (Util.transl conf "plugin_fixbase_FIXBASE" |> Adef.safe)
|
||||
@@ fun () ->
|
||||
Output.print_sstring conf {|<p>|};
|
||||
Output.print_sstring conf (Util.transl conf "plugin_fixbase_description");
|
||||
Output.print_sstring conf {|</p>|};
|
||||
let args =
|
||||
let input name txt =
|
||||
(Mutil.encode name, `Arg_Set, Util.transl conf txt |> Adef.safe)
|
||||
in
|
||||
[
|
||||
input arg_f_parents "plugin_fixbase_f_parents";
|
||||
input arg_f_children "plugin_fixbase_f_children";
|
||||
input arg_p_parents "plugin_fixbase_p_parents";
|
||||
input arg_p_NBDS "plugin_fixbase_p_NBDS";
|
||||
input arg_p_families "plugin_fixbase_p_families";
|
||||
input arg_pevents_witnesses "plugin_fixbase_pevents_witnesses";
|
||||
input arg_fevents_witnesses "plugin_fixbase_fevents_witnesses";
|
||||
input arg_marriage_divorce "plugin_fixbase_marriage_divorce";
|
||||
input arg_missing_spouses "plugin_fixbase_missing_spouses";
|
||||
input arg_invalid_utf8 "plugin_fixbase_invalid_utf8";
|
||||
input arg_p_key "plugin_fixbase_p_key";
|
||||
input arg_tstab "plugin_fixbase_tstab";
|
||||
]
|
||||
in
|
||||
UI.form conf
|
||||
(Adef.encoded "FIXBASE_OK")
|
||||
(Util.transl conf "plugin_fixbase_submit" |> Adef.safe)
|
||||
args
|
||||
|
||||
let fixbase_ok conf base =
|
||||
let dry_run = Util.p_getenv conf.env "dry_run" <> Some "off" in
|
||||
let process () =
|
||||
ignore @@ Unix.alarm 0;
|
||||
(* cancel timeout *)
|
||||
let base' = Gwdb.open_base @@ Util.base_path [] (bname base ^ ".gwb") in
|
||||
let ipers = ref [] in
|
||||
let ifams = ref [] in
|
||||
let istrs = ref [] in
|
||||
let report = function
|
||||
| Fixbase.Fix_NBDS ip
|
||||
| Fix_AddedUnion ip
|
||||
| Fix_AddedParents ip
|
||||
| Fix_ParentDeleted ip
|
||||
| Fix_AddedRelatedFromPevent (ip, _)
|
||||
| Fix_AddedRelatedFromFevent (ip, _)
|
||||
| Fix_UpdatedOcc (ip, _, _) ->
|
||||
ipers := ip :: !ipers
|
||||
| Fix_RemovedUnion (iper, ifam)
|
||||
| Fix_RemovedDuplicateUnion (iper, ifam)
|
||||
| Fix_MissingSpouse (ifam, iper) ->
|
||||
ifams := ifam :: !ifams;
|
||||
ipers := iper :: !ipers
|
||||
| Fix_MarriageDivorce ifam | Fix_AddedChild ifam ->
|
||||
ifams := ifam :: !ifams
|
||||
| Fix_WrongUTF8Encoding (ifam, iper, istr) ->
|
||||
istrs := (ifam, iper, istr) :: !istrs
|
||||
in
|
||||
let progress (_ : int) (_ : int) = () in
|
||||
let enabled = List.exists (UI.enabled conf) in
|
||||
if
|
||||
enabled
|
||||
[
|
||||
"marriage_divorce";
|
||||
"f_parents";
|
||||
"f_children";
|
||||
"fevents_witnesses";
|
||||
"missing_spouses";
|
||||
"invalid_utf8";
|
||||
]
|
||||
then Gwdb.load_families_array base;
|
||||
if enabled [ "invalid_utf8"; "p_key" ] then Gwdb.load_strings_array base;
|
||||
if enabled [ "f_parents"; "p_families" ] then Gwdb.load_unions_array base;
|
||||
if enabled [ "f_children"; "p_parents" ] then (
|
||||
Gwdb.load_descends_array base;
|
||||
Gwdb.load_ascends_array base);
|
||||
load_persons_array base;
|
||||
let opt s (fn : ?report:_ -> _ -> _ -> _) =
|
||||
if UI.enabled conf s then fn ~report progress base
|
||||
in
|
||||
wrap conf (Util.transl conf "plugin_fixbase_FIXBASE_OK" |> Adef.safe)
|
||||
@@ fun () ->
|
||||
opt "f_parents" Fixbase.check_families_parents;
|
||||
opt "f_children" Fixbase.check_families_children;
|
||||
opt "p_parents" Fixbase.check_persons_parents;
|
||||
opt "p_NBDS" Fixbase.check_NBDS;
|
||||
opt "p_families" Fixbase.check_persons_families;
|
||||
opt "pevents_witnesses" Fixbase.check_pevents_witnesses;
|
||||
opt "fevents_witnesses" Fixbase.check_fevents_witnesses;
|
||||
opt "marriage_divorce" Fixbase.fix_marriage_divorce;
|
||||
opt "missing_spouses" Fixbase.fix_missing_spouses;
|
||||
opt "invalid_utf8" Fixbase.fix_utf8_sequence;
|
||||
opt "p_key" Fixbase.fix_key;
|
||||
opt "p_key" Fixbase.fix_key;
|
||||
clear_persons_array base;
|
||||
clear_strings_array base;
|
||||
clear_families_array base;
|
||||
clear_unions_array base;
|
||||
clear_descends_array base;
|
||||
clear_ascends_array base;
|
||||
let ifneq x1 x2 label s =
|
||||
if x1 <> x2 then (
|
||||
Output.print_sstring conf {|<tr><td><b>|};
|
||||
Output.print_string conf label;
|
||||
Output.print_sstring conf {|</b></td><td>|};
|
||||
Output.print_string conf (s x1 |> Util.escape_html);
|
||||
Output.print_sstring conf {|</td><td>|};
|
||||
Output.print_string conf (s x2 |> Util.escape_html);
|
||||
Output.print_sstring conf {|</td></tr>|})
|
||||
in
|
||||
let dump_p p p' =
|
||||
let mka p =
|
||||
let a = gen_ascend_of_person p in
|
||||
{ a with parents = Option.map string_of_ifam a.parents }
|
||||
in
|
||||
let mku p =
|
||||
{ Def.family = Array.map string_of_ifam (gen_union_of_person p).family }
|
||||
in
|
||||
let mkp p =
|
||||
let p = gen_person_of_person p in
|
||||
let p = Futil.map_person_ps string_of_iper (sou base) p in
|
||||
{ p with key_index = string_of_iper p.key_index }
|
||||
in
|
||||
let a1 = mka p in
|
||||
let u1 = mku p in
|
||||
let p1 = mkp p in
|
||||
let a2 = mka p' in
|
||||
let u2 = mku p' in
|
||||
let p2 = mkp p' in
|
||||
let ifneq x1 x2 label s = ifneq x1 x2 (Util.escape_html label) s in
|
||||
ifneq p1.first_name p2.first_name "first_name" (fun s -> s);
|
||||
ifneq p1.surname p2.surname "surname" (fun s -> s);
|
||||
ifneq p1.occ p2.occ "occ" string_of_int;
|
||||
ifneq p1.image p2.image "image" (fun s -> s);
|
||||
ifneq p1.public_name p2.public_name "public_name" (fun s -> s);
|
||||
ifneq p1.qualifiers p2.qualifiers "qualifiers" [%show: string list];
|
||||
ifneq p1.aliases p2.aliases "aliases" [%show: string list];
|
||||
ifneq p1.first_names_aliases p2.first_names_aliases "first_names_aliases"
|
||||
[%show: string list];
|
||||
ifneq p1.surnames_aliases p2.surnames_aliases "surnames_aliases"
|
||||
[%show: string list];
|
||||
ifneq p1.titles p2.titles "titles" [%show: string Def_show.gen_title list];
|
||||
ifneq p1.rparents p2.rparents "rparents"
|
||||
[%show: (string, string) Def_show.gen_relation list];
|
||||
ifneq p1.related p2.related "related" [%show: string list];
|
||||
ifneq p1.occupation p2.occupation "occupation" (fun s -> s);
|
||||
ifneq p1.sex p2.sex "sex" [%show: Def_show.sex];
|
||||
ifneq p1.access p2.access "access" [%show: Def_show.access];
|
||||
ifneq p1.birth p2.birth "birth" [%show: Def_show.cdate];
|
||||
ifneq p1.birth_place p2.birth_place "birth_place" (fun s -> s);
|
||||
ifneq p1.birth_note p2.birth_note "birth_note" (fun s -> s);
|
||||
ifneq p1.birth_src p2.birth_src "birth_src" (fun s -> s);
|
||||
ifneq p1.baptism p2.baptism "baptism" [%show: Def_show.cdate];
|
||||
ifneq p1.baptism_place p2.baptism_place "baptism_place" (fun s -> s);
|
||||
ifneq p1.baptism_note p2.baptism_note "baptism_note" (fun s -> s);
|
||||
ifneq p1.baptism_src p2.baptism_src "baptism_src" (fun s -> s);
|
||||
ifneq p1.death p2.death "death" [%show: Def_show.death];
|
||||
ifneq p1.death_place p2.death_place "death_place" (fun s -> s);
|
||||
ifneq p1.death_note p2.death_note "death_note" (fun s -> s);
|
||||
ifneq p1.death_src p2.death_src "death_src" (fun s -> s);
|
||||
ifneq p1.burial p2.burial "burial" [%show: Def_show.burial];
|
||||
ifneq p1.burial_place p2.burial_place "burial_place" (fun s -> s);
|
||||
ifneq p1.burial_note p2.burial_note "burial_note" (fun s -> s);
|
||||
ifneq p1.burial_src p2.burial_src "burial_src" (fun s -> s);
|
||||
ifneq p1.pevents p2.pevents "pevents"
|
||||
[%show: (string, string) Def_show.gen_pers_event list];
|
||||
ifneq p1.notes p2.notes "notes" (fun s -> s);
|
||||
ifneq p1.psources p2.psources "psources" (fun s -> s);
|
||||
ifneq p1.key_index p2.key_index "key_index" (fun s -> s);
|
||||
ifneq a1.parents a2.parents "parents" [%show: string option];
|
||||
ifneq a1.consang a2.consang "consang" [%show: Def_show.fix];
|
||||
ifneq u1.family u2.family "family" [%show: string array]
|
||||
in
|
||||
let dump_f f f' =
|
||||
let mkf f =
|
||||
Futil.map_family_ps string_of_iper string_of_ifam (sou base)
|
||||
(gen_family_of_family f)
|
||||
in
|
||||
let mkc f =
|
||||
Futil.map_couple_p false string_of_iper (gen_couple_of_family f)
|
||||
in
|
||||
let mkd f =
|
||||
Futil.map_descend_p string_of_iper (gen_descend_of_family f)
|
||||
in
|
||||
let f1 = mkf f in
|
||||
let c1 = mkc f in
|
||||
let d1 = mkd f in
|
||||
let f2 = mkf f' in
|
||||
let c2 = mkc f' in
|
||||
let d2 = mkd f' in
|
||||
let ifneq x1 x2 label s = ifneq x1 x2 (Util.escape_html label) s in
|
||||
ifneq f1.marriage f2.marriage "marriage" [%show: Def_show.cdate];
|
||||
ifneq f1.marriage_place f2.marriage_place "marriage_place" (fun s -> s);
|
||||
ifneq f1.marriage_note f2.marriage_note "marriage_note" (fun s -> s);
|
||||
ifneq f1.marriage_src f2.marriage_src "marriage_src" (fun s -> s);
|
||||
ifneq f1.witnesses f2.witnesses "witnesses" [%show: string array];
|
||||
ifneq f1.relation f2.relation "relation" [%show: Def_show.relation_kind];
|
||||
ifneq f1.divorce f2.divorce "divorce" [%show: Def_show.divorce];
|
||||
ifneq f1.fevents f2.fevents "fevents"
|
||||
[%show: (string, string) Def_show.gen_fam_event list];
|
||||
ifneq f1.comment f2.comment "comment" (fun s -> s);
|
||||
ifneq f1.origin_file f2.origin_file "origin_file" (fun s -> s);
|
||||
ifneq f1.fsources f2.fsources "fsources" (fun s -> s);
|
||||
ifneq f1.fam_index f2.fam_index "fam_index" (fun s -> s);
|
||||
ifneq (Adef.father c1) (Adef.father c2) "father" (fun s -> s);
|
||||
ifneq (Adef.mother c1) (Adef.mother c2) "mother" (fun s -> s);
|
||||
ifneq d1.children d2.children "children" [%show: string array]
|
||||
in
|
||||
let string_of_p i =
|
||||
Printf.sprintf {|<a href="%s&i=%s">%s</a>|}
|
||||
(Util.commd conf :> string)
|
||||
(string_of_iper i |> Mutil.encode :> string)
|
||||
(Util.designation base (poi base i) : Adef.escaped_string :> string)
|
||||
|> Adef.safe
|
||||
in
|
||||
let string_of_f i =
|
||||
let fam = foi base i in
|
||||
Printf.sprintf "[%s & %s]"
|
||||
(string_of_p @@ get_father fam : Adef.safe_string :> string)
|
||||
(string_of_p @@ get_mother fam : Adef.safe_string :> string)
|
||||
|> Adef.safe
|
||||
in
|
||||
let dump string_of dump get data =
|
||||
List.iter
|
||||
(fun i ->
|
||||
Output.print_sstring conf "<b>";
|
||||
Output.print_string conf (string_of i);
|
||||
Output.print_sstring conf "</b>";
|
||||
Output.print_sstring conf "<table>";
|
||||
dump (get base' i) (get base i);
|
||||
Output.print_sstring conf "</table>")
|
||||
data
|
||||
in
|
||||
dump string_of_p dump_p poi !ipers;
|
||||
dump string_of_f dump_f foi !ifams;
|
||||
List.iter
|
||||
(fun (ifam_opt, iper_opt, opt) ->
|
||||
let aux, sou =
|
||||
match opt with
|
||||
| Some (i, i') -> (ifneq i i', sou base)
|
||||
| None -> (ifneq empty_string quest_string, fun _ -> "Dtext")
|
||||
in
|
||||
Output.print_sstring conf "<table>";
|
||||
aux
|
||||
(match ifam_opt with
|
||||
| Some i -> string_of_f i
|
||||
| None -> (
|
||||
match iper_opt with
|
||||
| Some i -> string_of_p i
|
||||
| None -> assert false))
|
||||
sou;
|
||||
Output.print_sstring conf "</table>")
|
||||
!istrs;
|
||||
let repost dry txt =
|
||||
Output.print_sstring conf {|<form action="|};
|
||||
Output.print_string conf (Util.commd conf);
|
||||
Output.print_sstring conf {|" method="GET">|};
|
||||
Output.print_sstring conf
|
||||
{|<input type="hidden" name="m" value="FIXBASE_OK">|};
|
||||
if not dry then
|
||||
Output.print_sstring conf
|
||||
{|<input type="hidden" name="dry_run" value="off">|};
|
||||
Output.print_sstring conf
|
||||
{|<input type="hidden" name="date_of_last_change" value="|};
|
||||
Output.print_sstring conf
|
||||
(Gwdb.date_of_last_change base |> string_of_float);
|
||||
Output.print_sstring conf {|">|};
|
||||
let opt s =
|
||||
if UI.enabled conf s then (
|
||||
Output.print_sstring conf {|<input type="hidden" name="|};
|
||||
Output.print_string conf (Mutil.encode s);
|
||||
Output.print_sstring conf {|" value="on">|})
|
||||
in
|
||||
opt "f_parents";
|
||||
opt "f_children";
|
||||
opt "p_parents";
|
||||
opt "p_NBDS";
|
||||
opt "p_families";
|
||||
opt "pevents_witnesses";
|
||||
opt "fevents_witnesses";
|
||||
opt "marriage_divorce";
|
||||
opt "missing_spouses";
|
||||
opt "invalid_utf8";
|
||||
opt "p_key";
|
||||
opt "tstab";
|
||||
Output.print_sstring conf {|<p>|};
|
||||
Output.print_sstring conf {|<input type="submit" value="|};
|
||||
Output.print_string conf txt;
|
||||
Output.print_sstring conf {|">|};
|
||||
Output.print_sstring conf {|</p>|};
|
||||
Output.print_sstring conf {|</form>|}
|
||||
in
|
||||
let tstab () =
|
||||
if UI.enabled conf "tstab" then (
|
||||
let bname = Util.base_path [] (bname base ^ ".gwb") in
|
||||
Mutil.rm (Filename.concat bname "tstab_visitor");
|
||||
Mutil.rm (Filename.concat bname "tstab");
|
||||
Output.print_sstring conf {|<p>|};
|
||||
Output.print_sstring conf (Util.transl conf "plugin_fixbase_ok_tstab");
|
||||
Output.print_sstring conf {|</p>|})
|
||||
in
|
||||
if not dry_run then
|
||||
if
|
||||
Util.p_getenv conf.env "date_of_last_change"
|
||||
= Some (Gwdb.date_of_last_change base |> string_of_float)
|
||||
then (
|
||||
Gwdb.commit_patches base;
|
||||
Output.print_sstring conf {|<p>|};
|
||||
Output.print_sstring conf
|
||||
(Util.transl conf "plugin_fixbase_ok_commit_patches");
|
||||
Output.print_sstring conf {|</p>|};
|
||||
tstab ())
|
||||
else if !ipers <> [] || !ifams <> [] || !istrs <> [] then (
|
||||
Output.print_sstring conf {|<p>|};
|
||||
Output.print_sstring conf
|
||||
(Util.transl conf "plugin_fixbase_ok_base_changed");
|
||||
Output.print_sstring conf {|</p>|};
|
||||
repost true (Util.transl conf "plugin_fixbase_ok_refresh" |> Adef.safe))
|
||||
else tstab ()
|
||||
else if !ipers <> [] || !ifams <> [] || !istrs <> [] then
|
||||
repost false (Util.transl conf "plugin_fixbase_ok_apply" |> Adef.safe)
|
||||
else (
|
||||
Output.print_sstring conf {|<p>|};
|
||||
Output.print_sstring conf (Util.transl conf "plugin_fixbase_ok_nothing");
|
||||
Output.print_sstring conf {|</p>|});
|
||||
Output.print_sstring conf {|<p><a href="|};
|
||||
Output.print_string conf (Util.commd conf : Adef.escaped_string);
|
||||
Output.print_sstring conf {|&m=FIXBASE">|};
|
||||
Output.print_sstring conf (Util.transl conf "plugin_fixbase_ok_return");
|
||||
Output.print_sstring conf {|</a></p>|}
|
||||
in
|
||||
if dry_run then process ()
|
||||
else
|
||||
Lock.control
|
||||
(Mutil.lock_file @@ Util.base_path [] (conf.bname ^ ".gwb"))
|
||||
false
|
||||
~onerror:(fun () -> !GWPARAM.output_error conf Def.Service_Unavailable)
|
||||
process
|
||||
|
||||
let ns = "fixbase"
|
||||
|
||||
let _ =
|
||||
let aux fn _assets conf base =
|
||||
if if opt_manitou then conf.manitou else conf.wizard then (
|
||||
fn conf base;
|
||||
true)
|
||||
else false
|
||||
in
|
||||
let w_base = Gwd_lib.Request.w_base ~none:(fun _ -> false) in
|
||||
Gwd_lib.GwdPlugin.register ~ns
|
||||
[
|
||||
("FIXBASE", fun assets -> w_base @@ aux fixbase assets);
|
||||
("FIXBASE_OK", fun assets -> w_base @@ aux fixbase_ok assets);
|
||||
]
|
||||
267
plugins/forum/assets/etc/forum.txt
Normal file
267
plugins/forum/assets/etc/forum.txt
Normal file
@ -0,0 +1,267 @@
|
||||
<!-- $Id: forum.txt v7.1 01/12/2023 00:17:17 $ -->
|
||||
<!-- Copyright (c) 1998-2007 INRIA -->
|
||||
<!DOCTYPE html>
|
||||
<html lang="%lang;">
|
||||
<head>
|
||||
<title>%nn;
|
||||
%if;(e.m = "FORUM_ADD" or e.m = "FORUM_ADD_OK")%nn;
|
||||
%if;can_post;
|
||||
[*add::message/previous message/previous messages/next message]0%nn;
|
||||
%else;
|
||||
[*incorrect request]%nn;
|
||||
%end;
|
||||
%elseif;(pos="")[*database forum]%nn;
|
||||
%elseif;(message.subject="" or message.subject="-")
|
||||
[*database forum]%nn;
|
||||
%else;
|
||||
%message.subject.cut.50;%nn;
|
||||
%end;
|
||||
</title>
|
||||
<meta name="robots" content="none">
|
||||
<meta charset="UTF-8">
|
||||
<meta name="viewport" content="width=device-width, initial-scale=1, shrink-to-fit=no">
|
||||
<link rel="shortcut icon" href="%images_prefix;favicon_gwd.png">
|
||||
%include;css
|
||||
<style>
|
||||
.clickable-row {
|
||||
cursor: pointer;
|
||||
}
|
||||
/* .clickable-row:hover {
|
||||
background-color: #f8f9fa;
|
||||
}*/
|
||||
</style>
|
||||
</head>
|
||||
<body%body_prop;>
|
||||
<div class="container">
|
||||
%message_to_wizard;
|
||||
%include;home
|
||||
%include;hed
|
||||
%if;(e.m!="FORUM" or e.p!="")
|
||||
<h1 class="ml-sm-2" href="%prefix;m=FORUM" accesskey="F">[*database forum]</h1>
|
||||
%else;
|
||||
<div class="d-flex align-items-center mt-1">
|
||||
<h1 class="ml-sm-2">[*database forum]</h1>
|
||||
%if;can_post;
|
||||
<a href="%url_set.m.FORUM_ADD" class="btn btn-primary ml-auto">
|
||||
[*add::message/previous message/previous messages/next message]0</a>
|
||||
%end;
|
||||
</div>
|
||||
%end;
|
||||
%define;search_form(xx)
|
||||
<form class="form-inline ml-sm-4 mt-2" method="get" action="%action;">
|
||||
%hidden;
|
||||
<input type="hidden" name="m" value="FORUM_SEARCH">
|
||||
%if;(xx=0)
|
||||
<input type="hidden" name="p" value="%pos;">
|
||||
%end;
|
||||
<label class="sr-only" for="fs">%e.s.ns;</label>
|
||||
<input class="form-control col-5" id="fs" name="s" placeholder="[*search/case sensitive]0">
|
||||
<div class="custom-control custom-checkbox ml-2">
|
||||
<input class="custom-control-input" type="checkbox" id="cs" name="c" value="on"
|
||||
%if;(xx=0 and e.c="on") checked%end;>
|
||||
<label class="custom-control-label" for="cs">[*search/case sensitive]1</label>
|
||||
</div>
|
||||
<button type="submit" class="btn btn-primary ml-3">[*search/case sensitive]0</button>
|
||||
</form>
|
||||
%end;
|
||||
%define;message()
|
||||
%if;supervisor;
|
||||
<b style="color:#999">-%sp;
|
||||
%if;(message.wizard!="")
|
||||
[wizard/wizards/friend/friends/exterior]0:%sp;
|
||||
<a href="%prefix;m=WIZNOTES&v=%message.wizard;" style="color:#999">%sq;
|
||||
%message.wizard;</a>%sp;
|
||||
%end;
|
||||
%if;(message.friend!="")
|
||||
[wizard/wizards/friend/friends/exterior]2: %message.friend;%sp;
|
||||
%end;
|
||||
…%message.from;</b>
|
||||
%end;
|
||||
<div>
|
||||
<b>[*ident/email/subject]0[:]</b> %message.ident;
|
||||
</div>
|
||||
%if;(message.email!="")%sp;
|
||||
<div>
|
||||
<b>[*ident/email/subject]1[:]</b> <a href="mailto:%message.email.v;">%message.email;</a>
|
||||
</div>
|
||||
%end;
|
||||
<div class="mt-2"><b>[*date/dates]0[:]</b> %message.time;</div>
|
||||
%if;(message.subject!="")
|
||||
<div><b>[*ident/email/subject]2[:]</b> %message.subject;</div>
|
||||
%end;
|
||||
|
||||
%if;(message.access="priv")
|
||||
<div><b>[*access]0[:]</b> [private]</div>
|
||||
%end;
|
||||
<div class="mt-2"><b>[*message/previous message/previous messages/next message]0[:]</b>
|
||||
<div>
|
||||
%if;(e.m="FORUM_VIEW")
|
||||
<textarea class="form-control p-2" rows="15" cols="100" readonly>%message.text.raw;</textarea>
|
||||
%elseif;(message.wiki="on")%message.text.wiki;
|
||||
%else;%message.text.nowiki;%end;</div>
|
||||
</div>
|
||||
%end;
|
||||
%if;(e.m="FORUM_ADD" or e.m="FORUM_ADD_OK")
|
||||
%( Add or preview a message %)
|
||||
%if;(e.m="FORUM_ADD_OK")
|
||||
%apply;message()
|
||||
<hr class="mt-4">
|
||||
%end;
|
||||
%if;can_post;
|
||||
<div class="h2">[*add::message/previous message/previous messages/next message]0</div>
|
||||
<form method="POST" action="%action;">
|
||||
%hidden;
|
||||
<input type="hidden" name="m" value="FORUM_ADD_OK">
|
||||
<div class="form-group row mb-1">
|
||||
<label for="ident" class="col-sm-2 col-form-label">[*ident/email/subject]0</label>
|
||||
<input id="ident" tabindex="1" class="form-control col-3" name="Ident"%sp;
|
||||
value="%if;(user.name="")%user.ident;%else;%user.name;%end;" required>
|
||||
</div>
|
||||
<div class="form-group row mb-3">
|
||||
<label for="email" class="col-sm-2 col-form-label">[*ident/email/subject]1 ([optional])</label>
|
||||
<input id="email" tabindex="2" class="form-control col-3" name="Email"
|
||||
%if;(e.m="FORUM_ADD_OK" and message.email!="") value="%message.email;"%end;>
|
||||
</div>
|
||||
<div class="form-group row mb-1">
|
||||
<label for="subject" class="col-sm-2 col-form-label">[*ident/email/subject]2 ([optional])</label>
|
||||
<input id="subject" tabindex="3" class="form-control col-6" name="Subject"
|
||||
%if;(e.m="FORUM_ADD_OK" and message.subject!="") value="%message.subject;"%end;>
|
||||
</div>
|
||||
<div class="form-group row">
|
||||
<label for="message" class="col-sm-2 col-form-label">%nn;
|
||||
[*message/previous message/previous messages/next message]0</label>
|
||||
<div class="d-inline-flex col-9 px-0">
|
||||
<textarea id="message" tabindex="4" class="form-control col-8 py-2 insert-character-target" name="Text" required>%nn;
|
||||
%if;(e.m="FORUM_ADD_OK")%message.text;%end;
|
||||
</textarea>
|
||||
<div class="col-4 px-0 ml-3">
|
||||
%include;characters
|
||||
</div>
|
||||
</div>
|
||||
</div>
|
||||
<div class="row">
|
||||
<div class="col-2"></div>
|
||||
<button tabindex="5" type="submit" name="visu" class="btn btn-primary">[*visualize/show/hide/summary]0</button>
|
||||
%if;(e.m="FORUM_ADD_OK")
|
||||
%if;(wizard or friend)
|
||||
<button tabindex="6" type="submit" name="publ_acc" class="btn btn-primary ml-2">[*public]0</button>
|
||||
<button tabindex="7" type="submit" name="priv_acc" class="btn btn-primary ml-2">[*private]0</button>
|
||||
%else;
|
||||
<button tabindex="6" type="submit" class="btn btn-primary ml-2">[*validate/delete]0</button>
|
||||
%end;
|
||||
%end;
|
||||
</div>
|
||||
%if;is_moderated_forum;
|
||||
<span>([this forum is moderated])</span>
|
||||
%end;
|
||||
</form>
|
||||
%else;
|
||||
<div class="h2">[*incorrect request]</div>
|
||||
%end;
|
||||
%elseif;(pos!="")
|
||||
%( display a message %)
|
||||
<ul class="mt-3">
|
||||
%if;(message.prev_pos!="")
|
||||
<li>
|
||||
<a href="%prefix;m=FORUM&p=%message.prev_pos;" accesskey="P">%nn;
|
||||
[*message/previous message/previous messages/next message]1%nn;
|
||||
</a>%nn;
|
||||
</li>
|
||||
%end;
|
||||
%if;(message.next_pos!="")
|
||||
<li>
|
||||
<a href="%prefix;m=FORUM&p=%message.next_pos;" accesskey="N">%nn;
|
||||
[*message/previous message/previous messages/next message]3%nn;
|
||||
</a>%nn;
|
||||
</li>
|
||||
%end;
|
||||
</ul>
|
||||
%let;col;%if;message.is_waiting; style="color:red"%end;%in;
|
||||
%if;message.is_waiting;
|
||||
%if;is_moderator;
|
||||
<form method="POST" action="%action;">
|
||||
%hidden;
|
||||
<input type="hidden" name="m" value="FORUM_VAL">
|
||||
<input type="hidden" name="p" value="%pos;">
|
||||
<button type="submit" name="v" value="yes" class="btn btn-primary">[*validate/delete]0</button>
|
||||
<button type="submit" name="d" value="yes" class="btn btn-primary">[*validate/delete]1</button>
|
||||
</form>
|
||||
%else;
|
||||
<span class="text-success">[*your message is waiting for validation]</span>
|
||||
%end;
|
||||
%end;
|
||||
%if;(e.m!="FORUM_VIEW")
|
||||
<div style="font-size:80%%;float:%right;;margin-%left;:3em">(<a%sp;
|
||||
href="%prefix;m=FORUM_VIEW&p=%message.pos;">[view source]</a>)</div>
|
||||
%end;
|
||||
<p%col;>
|
||||
%apply;message()
|
||||
%if;(message.wizard!="" and wizard and user.ident=message.wizard
|
||||
or manitou or supervisor)
|
||||
<form method="GET" action="%action;">
|
||||
%hidden;
|
||||
<input type="hidden" name="m" value="FORUM_P_P">
|
||||
<input type="hidden" name="p" value="%message.pos;">
|
||||
<button type="submit" class="btn btn-primary">[*public]/[*private]</button>
|
||||
</form>
|
||||
<form method="POST" action="%action;">
|
||||
%hidden;
|
||||
<input type="Hidden" name="m" value="FORUM_DEL">
|
||||
<input type="hidden" name="p" value="%message.pos;">
|
||||
<button type="submit" class="btn btn-primary">
|
||||
[*delete::message/previous message/previous messages/next message]0</button>
|
||||
</form>
|
||||
%end;
|
||||
%if;(e.m="FORUM_SEARCH")
|
||||
%apply;search_form(0)
|
||||
%end;
|
||||
%else;
|
||||
%( display message headers %)
|
||||
%let;len;%if;(e.len!="")%e.len;%else;100%end;%in;
|
||||
%let;to;%if;(e.to!="")%e.to;%else;-1%end;%in;
|
||||
<table class="table table-responsive table-hover mt-3">
|
||||
%foreach;message(to, len)
|
||||
%let;col;%if;message.is_waiting; text-danger%end;%in;
|
||||
%if;(message.date!=message.prev_date)
|
||||
%if;(message.prev_date!="" and message.date.month!=message.prev_date.month)
|
||||
<tr><td colspan="4"></td></tr>
|
||||
%end;
|
||||
<thead class="thead-light mt-3">
|
||||
<tr align="%left;"><th></th><th colspan="3" class="border-top-0"><b>%message.date;</b></th></tr>
|
||||
</thead>
|
||||
%end;
|
||||
<tbody><tr align="%left;" class="clickable-row text-align %col" data-href="%prefix;m=FORUM&p=%message.pos;"
|
||||
%if;(message.prev_date="") accesskey="1"%end;>
|
||||
<td><samp>%if;(message.access="priv")*%end;</samp></td>
|
||||
<td><samp>%message.hour;</samp></td>
|
||||
<td class="%col;"><b>%message.ident.cut.26;</b></td>
|
||||
<td>%nn;
|
||||
%if;(message.subject="" or message.subject="-")
|
||||
<i>… %message.text.cut.80;</i>%nn;
|
||||
%else;
|
||||
%message.subject.cut.80;%nn;
|
||||
%end;
|
||||
</td>
|
||||
</tr></tbody>
|
||||
%end;
|
||||
</table>
|
||||
%if;(pos!="")
|
||||
<a class="btn btn-primary ml-sm-4 mb-2" href="%prefix&m=FORUM&len=%len;&to=%pos;">%nn;
|
||||
[*message/previous message/previous messages/next message]2</a>
|
||||
%end;
|
||||
%apply;search_form(1)
|
||||
%end;
|
||||
%base_trailer;
|
||||
%include;copyr
|
||||
</div>
|
||||
%include;js
|
||||
<script>
|
||||
// Make table row clickable
|
||||
$(document).ready(function(){
|
||||
$(".clickable-row").click(function() {
|
||||
window.location = $(this).data("href");
|
||||
});
|
||||
});
|
||||
</script>
|
||||
</body>
|
||||
</html>
|
||||
21
plugins/forum/dune
Normal file
21
plugins/forum/dune
Normal file
@ -0,0 +1,21 @@
|
||||
(rule
|
||||
(target plugin_forum.ml)
|
||||
(deps
|
||||
(source_tree assets)
|
||||
(:included
|
||||
%{project_root}/plugins/forum/forum.ml
|
||||
%{project_root}/plugins/forum/forumDisplay.ml)
|
||||
(:src plugin_forum.cppo.ml))
|
||||
(action
|
||||
(run %{bin:cppo} %{src} -o %{target})))
|
||||
|
||||
(executable
|
||||
(name plugin_forum)
|
||||
(libraries geneweb geneweb.gwd_lib geneweb.wserver)
|
||||
(modes
|
||||
(native plugin))
|
||||
(modules plugin_forum))
|
||||
|
||||
(alias
|
||||
(name plugin)
|
||||
(deps plugin_forum.cmxs))
|
||||
500
plugins/forum/forum.ml
Normal file
500
plugins/forum/forum.ml
Normal file
@ -0,0 +1,500 @@
|
||||
(* Copyright (c) 1998-2007 INRIA *)
|
||||
|
||||
open Geneweb
|
||||
open Config
|
||||
open Def
|
||||
open Util
|
||||
|
||||
type message = {
|
||||
m_time : string;
|
||||
m_date : date;
|
||||
m_hour : string;
|
||||
m_waiting : bool;
|
||||
m_from : string;
|
||||
m_ident : string;
|
||||
m_wizard : string;
|
||||
m_friend : string;
|
||||
m_email : string;
|
||||
m_access : string;
|
||||
m_subject : string;
|
||||
m_wiki : string;
|
||||
m_text : string;
|
||||
}
|
||||
|
||||
module type MF = sig
|
||||
type in_chan
|
||||
type filename
|
||||
type pos
|
||||
|
||||
val filename_of_string : string -> filename
|
||||
val open_in : filename -> in_chan
|
||||
val last_pos : in_chan -> pos
|
||||
val not_a_pos : pos
|
||||
val prev_pos : pos -> pos
|
||||
val next_pos : pos -> pos
|
||||
val string_of_pos : pos -> Adef.safe_string
|
||||
val pos_of_string : string -> pos
|
||||
val input_char : in_chan -> char
|
||||
val input_line : in_chan -> string
|
||||
val rpos_in : in_chan -> pos
|
||||
val rseek_in : in_chan -> pos -> unit
|
||||
val close_in : in_chan -> unit
|
||||
val extend : filename -> (out_channel -> unit) -> unit
|
||||
val patch : filename -> pos -> string -> unit
|
||||
end
|
||||
|
||||
module MF : MF = struct
|
||||
type in_chan = {
|
||||
ic_fname : string;
|
||||
mutable ic_chan : in_channel;
|
||||
mutable ic_ext : int;
|
||||
}
|
||||
|
||||
type filename = string
|
||||
type pos = { mutable p_ord : bool; mutable p_ext : int; mutable p_pos : int }
|
||||
|
||||
let filename_of_string x = x
|
||||
|
||||
let last_pos ic =
|
||||
{ p_ord = true; p_ext = 0; p_pos = in_channel_length ic.ic_chan }
|
||||
|
||||
let not_a_pos = { p_ord = false; p_ext = 0; p_pos = -1 }
|
||||
let prev_pos pos = { pos with p_pos = pos.p_pos - 1 }
|
||||
let next_pos pos = { pos with p_pos = pos.p_pos + 1 }
|
||||
|
||||
let string_of_pos pos =
|
||||
if pos = not_a_pos then Adef.safe ""
|
||||
else if pos.p_ext = 0 then Adef.safe (string_of_int pos.p_pos)
|
||||
else Adef.safe (string_of_int pos.p_ext ^ "-" ^ string_of_int pos.p_pos)
|
||||
|
||||
let pos_of_string s =
|
||||
try
|
||||
let pos = int_of_string s in
|
||||
if pos < 0 then not_a_pos else { p_ord = true; p_ext = 0; p_pos = pos }
|
||||
with Failure _ -> (
|
||||
try
|
||||
Scanf.sscanf s "%d-%d" (fun a b ->
|
||||
{ p_ord = a = 0; p_ext = a; p_pos = b })
|
||||
with Scanf.Scan_failure _ -> not_a_pos)
|
||||
|
||||
let extend fname f =
|
||||
let tmp = fname ^ "~" in
|
||||
let oc = open_out tmp in
|
||||
(try f oc
|
||||
with e ->
|
||||
close_out oc;
|
||||
raise e);
|
||||
(match try Some (open_in fname) with Sys_error _ -> None with
|
||||
| Some ic ->
|
||||
(try
|
||||
while true do
|
||||
output_char oc (input_char ic)
|
||||
done
|
||||
with End_of_file -> ());
|
||||
close_in ic
|
||||
| None -> ());
|
||||
close_out oc;
|
||||
Mutil.rm fname;
|
||||
Sys.rename tmp fname
|
||||
|
||||
let patch fname pos str =
|
||||
let fname =
|
||||
if pos.p_ext = 0 then fname else fname ^ "." ^ string_of_int pos.p_ext
|
||||
in
|
||||
match try Some (open_in fname) with Sys_error _ -> None with
|
||||
| Some ic ->
|
||||
let tmp_fname = fname ^ "~" in
|
||||
let oc = open_out tmp_fname in
|
||||
let ic_len = in_channel_length ic in
|
||||
(let rec loop i =
|
||||
if i = ic_len then ()
|
||||
else
|
||||
let c = input_char ic in
|
||||
if
|
||||
i < ic_len - pos.p_pos
|
||||
|| i >= ic_len - pos.p_pos + String.length str
|
||||
then output_char oc c
|
||||
else output_char oc str.[i - ic_len + pos.p_pos];
|
||||
loop (i + 1)
|
||||
in
|
||||
loop 0);
|
||||
close_in ic;
|
||||
close_out oc;
|
||||
Mutil.rm fname;
|
||||
Sys.rename tmp_fname fname
|
||||
| None -> ()
|
||||
|
||||
let open_in fname =
|
||||
{ ic_fname = fname; ic_chan = open_in_bin fname; ic_ext = 0 }
|
||||
|
||||
let input_char ic = input_char ic.ic_chan
|
||||
|
||||
let rec input_line ic =
|
||||
try Stdlib.input_line ic.ic_chan
|
||||
with End_of_file ->
|
||||
let ext = ic.ic_ext + 1 in
|
||||
let fn = ic.ic_fname ^ "." ^ string_of_int ext in
|
||||
let ic2 = try open_in_bin fn with Sys_error _ -> raise End_of_file in
|
||||
close_in ic.ic_chan;
|
||||
ic.ic_chan <- ic2;
|
||||
ic.ic_ext <- ext;
|
||||
input_line ic
|
||||
|
||||
let rpos_in ic =
|
||||
let pos = in_channel_length ic.ic_chan - pos_in ic.ic_chan in
|
||||
{ p_ord = ic.ic_ext = 0; p_ext = ic.ic_ext; p_pos = pos }
|
||||
|
||||
let rec rseek_in ic pos =
|
||||
if ic.ic_ext = pos.p_ext then
|
||||
let len = in_channel_length ic.ic_chan in
|
||||
if pos.p_pos > len then
|
||||
if pos.p_ext >= 1 then (
|
||||
let ext = ic.ic_ext - 1 in
|
||||
pos.p_ord <- ext = 0;
|
||||
pos.p_ext <- ext;
|
||||
pos.p_pos <- pos.p_pos - len;
|
||||
rseek_in ic pos)
|
||||
else invalid_arg "rseek_in"
|
||||
else seek_in ic.ic_chan (len - pos.p_pos)
|
||||
else
|
||||
let fn =
|
||||
if pos.p_ext = 0 then ic.ic_fname
|
||||
else ic.ic_fname ^ "." ^ string_of_int pos.p_ext
|
||||
in
|
||||
let ic2 = try open_in_bin fn with Sys_error _ -> failwith "rseek_in" in
|
||||
close_in ic.ic_chan;
|
||||
ic.ic_chan <- ic2;
|
||||
ic.ic_ext <- pos.p_ext;
|
||||
rseek_in ic pos
|
||||
|
||||
let close_in ic = close_in ic.ic_chan
|
||||
end
|
||||
|
||||
let forum_file conf =
|
||||
let fn = Filename.concat (bpath (conf.bname ^ ".gwb")) "forum" in
|
||||
MF.filename_of_string fn
|
||||
|
||||
(* Black list *)
|
||||
|
||||
let match_strings regexp s =
|
||||
let rec loop i j =
|
||||
if i = String.length regexp && j = String.length s then true
|
||||
else if i = String.length regexp then false
|
||||
else if j = String.length s then false
|
||||
else if regexp.[i] = s.[j] then loop (i + 1) (j + 1)
|
||||
else if regexp.[i] = '*' then
|
||||
if i + 1 = String.length regexp then true
|
||||
else if regexp.[i + 1] = s.[j] then loop (i + 2) (j + 1)
|
||||
else loop i (j + 1)
|
||||
else false
|
||||
in
|
||||
loop 0 0
|
||||
|
||||
let can_post conf =
|
||||
try
|
||||
let fname = List.assoc "forum_exclude_file" conf.base_env in
|
||||
let fname = Util.bpath fname in
|
||||
let ic = open_in fname in
|
||||
let rec loop () =
|
||||
match try Some (input_line ic) with End_of_file -> None with
|
||||
| Some line ->
|
||||
if match_strings line conf.from then (
|
||||
close_in ic;
|
||||
false)
|
||||
else loop ()
|
||||
| None ->
|
||||
close_in ic;
|
||||
true
|
||||
in
|
||||
loop ()
|
||||
with Not_found | Sys_error _ -> true
|
||||
|
||||
(* Print headers *)
|
||||
|
||||
let get_var ic lab s =
|
||||
let len = String.length lab in
|
||||
if String.length s >= len && String.sub s 0 len = lab then
|
||||
let start =
|
||||
if String.length s > len && s.[len] = ' ' then len + 1 else len
|
||||
in
|
||||
(String.sub s start (String.length s - start), MF.input_line ic)
|
||||
else ("", s)
|
||||
|
||||
let size_of_char s i = Utf8.nbc s.[i]
|
||||
|
||||
let string_length s i =
|
||||
let rec loop i =
|
||||
if i >= String.length s then 0
|
||||
else
|
||||
let size = size_of_char s i in
|
||||
size + loop (i + size)
|
||||
in
|
||||
loop i
|
||||
|
||||
let sp2nbsp lim s =
|
||||
let trunc_signature = "..." in
|
||||
let signature_length = string_length trunc_signature 0 in
|
||||
let rec loop i len lim =
|
||||
if i >= String.length s || s.[i] = '\n' then Buff.get len
|
||||
else if lim <= 0 && string_length s i > signature_length then
|
||||
Buff.get len ^ trunc_signature
|
||||
else
|
||||
let size = size_of_char s i in
|
||||
let len =
|
||||
match s.[i] with
|
||||
| ' ' -> Buff.mstore len " "
|
||||
| '&' -> Buff.mstore len "&"
|
||||
| _ -> Buff.mstore len (String.sub s i size)
|
||||
in
|
||||
loop (i + size) len (lim - 1)
|
||||
in
|
||||
loop 0 0 lim
|
||||
|
||||
(* Print a message *)
|
||||
|
||||
let read_message conf ic =
|
||||
try
|
||||
let s = MF.input_line ic in
|
||||
let time, s = get_var ic "Time:" s in
|
||||
let (time, s), deleted =
|
||||
if time = "" then (get_var ic "****:" s, true) else ((time, s), false)
|
||||
in
|
||||
let date, hour =
|
||||
try
|
||||
let i = String.index time ' ' in
|
||||
( String.sub time 0 i,
|
||||
String.sub time (i + 1) (String.length time - i - 1) )
|
||||
with Not_found -> ("", time)
|
||||
in
|
||||
let date =
|
||||
try
|
||||
let y = int_of_string (String.sub date 0 4) in
|
||||
let m = int_of_string (String.sub date 5 2) in
|
||||
let d = int_of_string (String.sub date 8 2) in
|
||||
Dgreg
|
||||
({ year = y; month = m; day = d; prec = Sure; delta = 0 }, Dgregorian)
|
||||
with Failure _ | Invalid_argument _ -> Dtext date
|
||||
in
|
||||
let moderator, s = get_var ic "Moderator:" s in
|
||||
let from, s = get_var ic "From:" s in
|
||||
let ident, s = get_var ic "Ident:" s in
|
||||
let wizard, s = get_var ic "Wizard:" s in
|
||||
let friend, s = get_var ic "Friend:" s in
|
||||
let email, s = get_var ic "Email:" s in
|
||||
let access, s = get_var ic "Access:" s in
|
||||
let subject, s = get_var ic "Subject:" s in
|
||||
let wiki, s = get_var ic "Wiki:" s in
|
||||
let _, s = get_var ic "Text:" s in
|
||||
let mess =
|
||||
let rec get_mess len s =
|
||||
if String.length s >= 2 && s.[0] = ' ' && s.[1] = ' ' then
|
||||
let s = String.sub s 2 (String.length s - 2) in
|
||||
let len = if len = 0 then len else Buff.store len '\n' in
|
||||
get_mess (Buff.mstore len s) (MF.input_line ic)
|
||||
else Buff.get len
|
||||
in
|
||||
get_mess 0 s
|
||||
in
|
||||
let waiting = String.length moderator > 0 && moderator.[0] = '.' in
|
||||
let mess =
|
||||
{
|
||||
m_time = time;
|
||||
m_waiting = waiting;
|
||||
m_from = from;
|
||||
m_date = date;
|
||||
m_hour = hour;
|
||||
m_ident = ident;
|
||||
m_wizard = wizard;
|
||||
m_friend = friend;
|
||||
m_email = email;
|
||||
m_access = access;
|
||||
m_subject = subject;
|
||||
m_wiki = wiki;
|
||||
m_text = mess;
|
||||
}
|
||||
in
|
||||
let accessible =
|
||||
if deleted then false
|
||||
else if access <> "publ" && (not conf.wizard) && not conf.friend then
|
||||
false
|
||||
else true
|
||||
in
|
||||
Some (mess, accessible)
|
||||
with End_of_file -> None
|
||||
|
||||
let get_message conf pos =
|
||||
let fname = forum_file conf in
|
||||
match try Some (MF.open_in fname) with Sys_error _ -> None with
|
||||
| Some ic ->
|
||||
MF.rseek_in ic pos;
|
||||
let r =
|
||||
match read_message conf ic with
|
||||
| Some (m, accessible) -> Some (accessible, m, pos, MF.rpos_in ic)
|
||||
| None -> None
|
||||
in
|
||||
MF.close_in ic;
|
||||
r
|
||||
| None -> None
|
||||
|
||||
let backward_pos conf pos =
|
||||
let fname = forum_file conf in
|
||||
match try Some (MF.open_in fname) with Sys_error _ -> None with
|
||||
| Some ic ->
|
||||
let sync_txt = "\nTime: " in
|
||||
let sync_txt_last = String.length sync_txt - 1 in
|
||||
let last_pos = MF.last_pos ic in
|
||||
let new_pos =
|
||||
let rec loop new_pos i =
|
||||
let new_pos = MF.next_pos new_pos in
|
||||
if new_pos = last_pos && i = 1 then new_pos
|
||||
else if new_pos < last_pos then (
|
||||
MF.rseek_in ic new_pos;
|
||||
let c = MF.input_char ic in
|
||||
if c = sync_txt.[i] then
|
||||
if i = 0 then MF.prev_pos new_pos else loop new_pos (i - 1)
|
||||
else loop new_pos sync_txt_last)
|
||||
else pos
|
||||
in
|
||||
loop pos sync_txt_last
|
||||
in
|
||||
MF.close_in ic;
|
||||
new_pos
|
||||
| None -> pos
|
||||
|
||||
let passwd_in_file conf kind =
|
||||
match List.assoc_opt (kind ^ "_passwd_file") conf.base_env with
|
||||
| Some "" | None -> false
|
||||
| Some _ -> true
|
||||
|
||||
let moderators conf =
|
||||
match List.assoc_opt "moderator_file" conf.base_env with
|
||||
| None | Some "" -> []
|
||||
| Some fname -> (
|
||||
let fname = Util.bpath fname in
|
||||
match try Some (Secure.open_in fname) with Sys_error _ -> None with
|
||||
| Some ic ->
|
||||
let list =
|
||||
let rec loop list =
|
||||
match try Some (input_line ic) with End_of_file -> None with
|
||||
| Some line -> loop (line :: list)
|
||||
| None -> List.rev list
|
||||
in
|
||||
loop []
|
||||
in
|
||||
close_in ic;
|
||||
list
|
||||
| None -> [])
|
||||
|
||||
let is_moderator conf = conf.wizard && List.mem conf.user (moderators conf)
|
||||
|
||||
let is_visible conf mess =
|
||||
(not mess.m_waiting) || is_moderator conf
|
||||
|| (conf.wizard && mess.m_wizard <> "" && mess.m_wizard = conf.user)
|
||||
|
||||
(* Send a message *)
|
||||
|
||||
let get conf key =
|
||||
match p_getenv conf.env key with
|
||||
| Some v -> v
|
||||
| None -> failwith (key ^ " unbound")
|
||||
|
||||
let get1 conf key =
|
||||
only_printable_or_nl (Mutil.strip_all_trailing_spaces (get conf key))
|
||||
|
||||
let forum_add conf _base moderated mess =
|
||||
let access =
|
||||
if conf.wizard || conf.friend then
|
||||
match p_getenv conf.env "priv_acc" with
|
||||
| Some _ -> "priv"
|
||||
| None -> "publ"
|
||||
else "publ"
|
||||
in
|
||||
if mess.m_ident <> "" && mess.m_text <> "" then
|
||||
MF.extend (forum_file conf) (fun oc ->
|
||||
Printf.fprintf oc "Time: %s\n" (Util.sprintf_today conf :> string);
|
||||
if moderated then Printf.fprintf oc "Moderator: ....................\n";
|
||||
Printf.fprintf oc "From: %s\n" conf.from;
|
||||
Printf.fprintf oc "Ident: %s\n" mess.m_ident;
|
||||
if (conf.wizard || conf.just_friend_wizard) && conf.user <> "" then
|
||||
Printf.fprintf oc "Wizard: %s\n" conf.user;
|
||||
if conf.friend && (not conf.just_friend_wizard) && conf.user <> "" then
|
||||
Printf.fprintf oc "Friend: %s\n" conf.user;
|
||||
if mess.m_email <> "" then Printf.fprintf oc "Email: %s\n" mess.m_email;
|
||||
Printf.fprintf oc "Access: %s\n" access;
|
||||
let subject = if mess.m_subject = "" then "-" else mess.m_subject in
|
||||
Printf.fprintf oc "Subject: %s\n" subject;
|
||||
Printf.fprintf oc "Wiki: on\n";
|
||||
Printf.fprintf oc "Text:\n";
|
||||
let txt = mess.m_text in
|
||||
let rec loop i bol =
|
||||
if i = String.length txt then ()
|
||||
else (
|
||||
if bol then Printf.fprintf oc " ";
|
||||
if txt.[i] <> '\r' then output_char oc txt.[i];
|
||||
loop (i + 1) (txt.[i] = '\n'))
|
||||
in
|
||||
loop 0 true;
|
||||
Printf.fprintf oc "\n\n")
|
||||
|
||||
(* Deleting a message *)
|
||||
|
||||
let forum_del conf pos =
|
||||
let fname = forum_file conf in
|
||||
MF.patch fname pos "****"
|
||||
|
||||
let find_next_pos conf =
|
||||
let rec loop pos =
|
||||
let back_pos = backward_pos conf pos in
|
||||
match get_message conf back_pos with
|
||||
| Some (acc, _, _, _) ->
|
||||
if back_pos = pos then None
|
||||
else if acc then Some back_pos
|
||||
else loop back_pos
|
||||
| None -> None
|
||||
in
|
||||
loop
|
||||
|
||||
(* validate *)
|
||||
|
||||
let set_validator conf pos =
|
||||
let fname = forum_file conf in
|
||||
match try Some (MF.open_in fname) with Sys_error _ -> None with
|
||||
| Some ic ->
|
||||
MF.rseek_in ic pos;
|
||||
let _ = MF.input_line ic in
|
||||
let pos = MF.rpos_in ic in
|
||||
let s = MF.input_line ic in
|
||||
let moderator, _ = get_var ic "Moderator:" s in
|
||||
MF.close_in ic;
|
||||
if moderator <> "" && moderator.[0] = '.' then (
|
||||
let m =
|
||||
let len = String.length moderator in
|
||||
if String.length conf.user < len - 1 then conf.user
|
||||
else String.sub conf.user 0 (len - 1)
|
||||
in
|
||||
MF.patch fname pos (Printf.sprintf "Moderator: /%s" m);
|
||||
true)
|
||||
else false
|
||||
| None -> false
|
||||
|
||||
(* access switch *)
|
||||
|
||||
let set_access conf pos =
|
||||
let rec get_access ic =
|
||||
let pos = MF.rpos_in ic in
|
||||
let s = MF.input_line ic in
|
||||
let access, _ = get_var ic "Access:" s in
|
||||
if access = "" then get_access ic else (access, pos)
|
||||
in
|
||||
let fname = forum_file conf in
|
||||
match try Some (MF.open_in fname) with Sys_error _ -> None with
|
||||
| Some ic ->
|
||||
MF.rseek_in ic pos;
|
||||
let access, pos = get_access ic in
|
||||
MF.close_in ic;
|
||||
if access = "publ" || access = "priv" then (
|
||||
let new_access = match access with "publ" -> "priv" | _ -> "publ" in
|
||||
MF.patch fname pos (Printf.sprintf "Access: %s" new_access);
|
||||
true)
|
||||
else false
|
||||
| None -> false
|
||||
501
plugins/forum/forumDisplay.ml
Normal file
501
plugins/forum/forumDisplay.ml
Normal file
@ -0,0 +1,501 @@
|
||||
(* Copyright (c) 1998-2007 INRIA *)
|
||||
|
||||
open Geneweb
|
||||
open Config
|
||||
open Def
|
||||
open TemplAst
|
||||
open Util
|
||||
open Forum
|
||||
|
||||
type 'a env =
|
||||
| Vmess of message * message option * MF.pos * MF.pos * string option
|
||||
| Vpos of MF.pos ref
|
||||
| Vother of 'a
|
||||
| Vnone
|
||||
|
||||
let get_env v env = try List.assoc v env with Not_found -> Vnone
|
||||
let get_vother = function Vother x -> Some x | _ -> None
|
||||
let set_vother x = Vother x
|
||||
|
||||
let print_foreach conf _base print_ast eval_expr =
|
||||
let eval_int_expr env e =
|
||||
let s = eval_expr env () e in
|
||||
try int_of_string s with Failure _ -> raise Not_found
|
||||
in
|
||||
let rec print_foreach env _xx _loc s sl el al =
|
||||
match s :: sl with
|
||||
| [ "message" ] -> print_foreach_message env el al
|
||||
| _ -> raise Not_found
|
||||
and print_foreach_message env el al =
|
||||
let eval_pos_expr env e = MF.pos_of_string (eval_expr env () e) in
|
||||
let to_pos, max_mess =
|
||||
match el with
|
||||
| [ [ e1 ]; [ e2 ] ] -> (eval_pos_expr env e1, eval_int_expr env e2)
|
||||
| _ -> raise Not_found
|
||||
in
|
||||
let fname = forum_file conf in
|
||||
match try Some (MF.open_in fname) with Sys_error _ -> None with
|
||||
| Some ic ->
|
||||
let rec loop prev_mess i =
|
||||
if i >= max_mess then MF.rpos_in ic
|
||||
else
|
||||
let pos = MF.rpos_in ic in
|
||||
match read_message conf ic with
|
||||
| Some (mess, accessible) ->
|
||||
if accessible && is_visible conf mess then (
|
||||
let next_pos = MF.rpos_in ic in
|
||||
let vmess = Vmess (mess, prev_mess, pos, next_pos, None) in
|
||||
let env = ("mess", vmess) :: env in
|
||||
List.iter (print_ast env ()) al;
|
||||
loop (Some mess) (i + 1))
|
||||
else loop prev_mess i
|
||||
| None -> MF.not_a_pos
|
||||
in
|
||||
(if to_pos = MF.not_a_pos then ()
|
||||
else try MF.rseek_in ic to_pos with Sys_error _ -> ());
|
||||
let pos = loop None 0 in
|
||||
(match get_env "pos" env with Vpos r -> r := pos | _ -> ());
|
||||
MF.close_in ic
|
||||
| None -> ()
|
||||
in
|
||||
print_foreach
|
||||
|
||||
let str_val x = VVstring x
|
||||
|
||||
let safe_val (x : [< `encoded | `escaped | `safe ] Adef.astring) =
|
||||
VVstring ((x :> Adef.safe_string) :> string)
|
||||
|
||||
let rec eval_var conf base env _xx _loc = function
|
||||
| [ "can_post" ] -> VVbool (can_post conf)
|
||||
| [ "is_moderated_forum" ] -> VVbool (moderators conf <> [])
|
||||
| [ "is_moderator" ] -> VVbool (is_moderator conf)
|
||||
| "message" :: sl -> eval_message_var conf base env sl
|
||||
| [ "pos" ] -> (
|
||||
match get_env "pos" env with
|
||||
| Vpos r -> safe_val (MF.string_of_pos !r)
|
||||
| _ -> raise Not_found)
|
||||
| _ -> raise Not_found
|
||||
|
||||
and eval_message_var conf base env = function
|
||||
| [ "access" ] -> (
|
||||
match get_env "mess" env with
|
||||
| Vmess (mess, _, _, _, _) -> str_val mess.m_access
|
||||
| _ -> raise Not_found)
|
||||
| "date" :: sl -> (
|
||||
match get_env "mess" env with
|
||||
| Vmess (mess, _, _, _, _) -> eval_date_var conf mess.m_date sl
|
||||
| _ -> raise Not_found)
|
||||
| "email" :: sl -> (
|
||||
match get_env "mess" env with
|
||||
| Vmess (mess, _, _, _, so) ->
|
||||
eval_message_string_var conf mess.m_email so sl
|
||||
| _ -> raise Not_found)
|
||||
| [ "friend" ] ->
|
||||
if passwd_in_file conf "friend" then
|
||||
match get_env "mess" env with
|
||||
| Vmess (mess, _, _, _, _) -> str_val mess.m_friend
|
||||
| _ -> raise Not_found
|
||||
else str_val ""
|
||||
| [ "from" ] -> (
|
||||
match get_env "mess" env with
|
||||
| Vmess (mess, _, _, _, _) -> str_val mess.m_from
|
||||
| _ -> raise Not_found)
|
||||
| [ "hour" ] -> (
|
||||
match get_env "mess" env with
|
||||
| Vmess (mess, _, _, _, _) -> str_val mess.m_hour
|
||||
| _ -> raise Not_found)
|
||||
| "ident" :: sl -> (
|
||||
match get_env "mess" env with
|
||||
| Vmess (mess, _, _, _, so) ->
|
||||
eval_message_string_var conf mess.m_ident so sl
|
||||
| _ -> raise Not_found)
|
||||
| [ "is_waiting" ] -> (
|
||||
match get_env "mess" env with
|
||||
| Vmess (mess, _, _, _, _) -> VVbool mess.m_waiting
|
||||
| _ -> raise Not_found)
|
||||
| [ "next_pos" ] -> (
|
||||
match get_env "mess" env with
|
||||
| Vmess (_, _, pos, _, _) ->
|
||||
let rec loop pos =
|
||||
let back_pos = backward_pos conf pos in
|
||||
match get_message conf back_pos with
|
||||
| Some (acc, mess, _, _) ->
|
||||
if back_pos = pos then str_val ""
|
||||
else if acc && is_visible conf mess then
|
||||
safe_val (MF.string_of_pos back_pos)
|
||||
else loop back_pos
|
||||
| None -> str_val ""
|
||||
in
|
||||
loop pos
|
||||
| _ -> raise Not_found)
|
||||
| [ "pos" ] -> (
|
||||
match get_env "mess" env with
|
||||
| Vmess (_, _, pos, _, _) -> safe_val (MF.string_of_pos pos)
|
||||
| _ -> raise Not_found)
|
||||
| "prev_date" :: sl -> (
|
||||
match get_env "mess" env with
|
||||
| Vmess (_, prev_mess, _, _, _) -> (
|
||||
match prev_mess with
|
||||
| Some mess -> eval_date_var conf mess.m_date sl
|
||||
| None -> str_val "")
|
||||
| _ -> raise Not_found)
|
||||
| [ "prev_pos" ] -> (
|
||||
match get_env "mess" env with
|
||||
| Vmess (_, _, _, next_pos, _) ->
|
||||
let rec loop next_pos =
|
||||
match get_message conf next_pos with
|
||||
| Some (acc, mess, next_pos, next_next_pos) ->
|
||||
if acc && is_visible conf mess then
|
||||
safe_val (MF.string_of_pos next_pos)
|
||||
else loop next_next_pos
|
||||
| None -> str_val ""
|
||||
in
|
||||
loop next_pos
|
||||
| _ -> raise Not_found)
|
||||
| "subject" :: sl -> (
|
||||
match get_env "mess" env with
|
||||
| Vmess (m, _, _, _, so) -> eval_message_string_var conf m.m_subject so sl
|
||||
| _ -> raise Not_found)
|
||||
| "text" :: sl -> (
|
||||
match get_env "mess" env with
|
||||
| Vmess (m, _, _, _, so) -> eval_message_text_var conf base m.m_text so sl
|
||||
| _ -> raise Not_found)
|
||||
| "time" :: sl -> (
|
||||
match get_env "mess" env with
|
||||
| Vmess (m, _, _, _, so) -> eval_message_text_var conf base m.m_time so sl
|
||||
| _ -> raise Not_found)
|
||||
| [ "wiki" ] -> (
|
||||
match get_env "mess" env with
|
||||
| Vmess (mess, _, _, _, _) -> str_val mess.m_wiki
|
||||
| _ -> raise Not_found)
|
||||
| [ "wizard" ] ->
|
||||
if passwd_in_file conf "wizard" then
|
||||
match get_env "mess" env with
|
||||
| Vmess (mess, _, _, _, _) -> str_val mess.m_wizard
|
||||
| _ -> raise Not_found
|
||||
else str_val ""
|
||||
| _ -> raise Not_found
|
||||
|
||||
and eval_date_var conf date = function
|
||||
| [ "month" ] -> (
|
||||
match date with
|
||||
| Dgreg (d, _) -> str_val (string_of_int d.month)
|
||||
| _ -> str_val "")
|
||||
| [] ->
|
||||
str_val
|
||||
(Util.translate_eval (DateDisplay.string_of_date conf date :> string))
|
||||
| _ -> raise Not_found
|
||||
|
||||
and eval_message_text_var conf base str so = function
|
||||
| [ "wiki" ] ->
|
||||
let s = string_with_macros conf [] str in
|
||||
let lines = Wiki.html_of_tlsw conf s in
|
||||
let s = String.concat "\n" lines in
|
||||
let s =
|
||||
let wi =
|
||||
{
|
||||
Wiki.wi_mode = "NOTES";
|
||||
Wiki.wi_file_path = Notes.file_path conf base;
|
||||
Wiki.wi_person_exists = person_exists conf base;
|
||||
Wiki.wi_always_show_link = conf.wizard || conf.friend;
|
||||
}
|
||||
in
|
||||
Wiki.syntax_links conf wi s
|
||||
in
|
||||
let s =
|
||||
match so with
|
||||
| Some h ->
|
||||
let case_sens = p_getenv conf.env "c" = Some "on" in
|
||||
html_highlight case_sens h s
|
||||
| None -> s
|
||||
in
|
||||
str_val s
|
||||
| [ "nowiki" ] ->
|
||||
let s = string_with_macros conf [] str in
|
||||
let s =
|
||||
match so with
|
||||
| Some h ->
|
||||
let case_sens = p_getenv conf.env "c" = Some "on" in
|
||||
html_highlight case_sens h s
|
||||
| None -> s
|
||||
in
|
||||
str_val s
|
||||
| [ "raw" ] -> str_val str
|
||||
| sl -> eval_message_string_var conf str so sl
|
||||
|
||||
and eval_message_string_var conf str so = function
|
||||
| [ "cut"; s ] -> (
|
||||
try str_val (sp2nbsp (int_of_string s) str)
|
||||
with Failure _ -> raise Not_found)
|
||||
| [ "v" ] -> safe_val (Util.escape_html str)
|
||||
| [] ->
|
||||
let s = Util.escape_html str in
|
||||
let s =
|
||||
match so with
|
||||
| Some h ->
|
||||
let case_sens = p_getenv conf.env "c" = Some "on" in
|
||||
html_highlight case_sens h (s : Adef.escaped_string :> string)
|
||||
|> Adef.escaped
|
||||
| None -> s
|
||||
in
|
||||
safe_val s
|
||||
| _ -> raise Not_found
|
||||
|
||||
let visualize conf base mess =
|
||||
let vmess = Vmess (mess, None, MF.not_a_pos, MF.not_a_pos, None) in
|
||||
let env = [ ("mess", vmess) ] in
|
||||
Hutil.interp conf "forum"
|
||||
{
|
||||
Templ.eval_var = eval_var conf base;
|
||||
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 = print_foreach conf base;
|
||||
}
|
||||
env ()
|
||||
|
||||
let message_txt conf n =
|
||||
transl_nth conf "message/previous message/previous messages/next message" n
|
||||
|
||||
let print_aux conf pos title =
|
||||
Hutil.header conf title;
|
||||
Hutil.print_link_to_welcome conf true;
|
||||
(match pos with
|
||||
| Some pos ->
|
||||
Output.print_sstring conf {|<a href="|};
|
||||
Output.print_string conf (commd conf);
|
||||
Output.print_sstring conf {|m=FORUM&p=|};
|
||||
Output.print_string conf (MF.string_of_pos pos);
|
||||
Output.print_sstring conf {|">|};
|
||||
message_txt conf 3 (* FIXME: safe_string? *)
|
||||
|> Utf8.capitalize_fst |> Output.print_sstring conf;
|
||||
Output.print_sstring conf {|</a>|}
|
||||
| None ->
|
||||
Output.print_sstring conf {|<a href="|};
|
||||
Output.print_string conf (commd conf);
|
||||
Output.print_sstring conf {|m=FORUM">|};
|
||||
transl conf "database forum"
|
||||
|> Utf8.capitalize_fst |> Output.print_sstring conf;
|
||||
Output.print_sstring conf {|</a>|});
|
||||
Hutil.trailer conf
|
||||
|
||||
let print_del_ok conf next_pos =
|
||||
print_aux conf next_pos @@ fun _ ->
|
||||
transl conf "message deleted"
|
||||
|> Utf8.capitalize_fst |> Output.print_sstring conf
|
||||
|
||||
let print_valid_ok conf pos del =
|
||||
print_aux conf pos @@ fun _ ->
|
||||
if del then
|
||||
transl conf "message deleted"
|
||||
|> Utf8.capitalize_fst |> Output.print_sstring conf
|
||||
else
|
||||
transl conf "message added"
|
||||
|> Utf8.capitalize_fst |> Output.print_sstring conf
|
||||
|
||||
let print_forum_message conf base r so =
|
||||
let env =
|
||||
match r with
|
||||
| Some (acc, mess, pos, next_pos) ->
|
||||
if acc && is_visible conf mess then
|
||||
[
|
||||
("mess", Vmess (mess, None, pos, next_pos, so));
|
||||
("pos", Vpos (ref pos));
|
||||
]
|
||||
else [ ("pos", Vpos (ref MF.not_a_pos)) ]
|
||||
| None -> [ ("pos", Vpos (ref MF.not_a_pos)) ]
|
||||
in
|
||||
Hutil.interp conf "forum"
|
||||
{
|
||||
Templ.eval_var = eval_var conf base;
|
||||
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 = print_foreach conf base;
|
||||
}
|
||||
env ()
|
||||
|
||||
let print_forum_headers conf base =
|
||||
let env = [ ("pos", Vpos (ref MF.not_a_pos)) ] in
|
||||
Hutil.interp conf "forum"
|
||||
{
|
||||
Templ.eval_var = eval_var conf base;
|
||||
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 = print_foreach conf base;
|
||||
}
|
||||
env ()
|
||||
|
||||
let valid_forum_message conf base pos =
|
||||
match get_message conf pos with
|
||||
| Some (a, _, _, _) ->
|
||||
if a && conf.wizard && List.mem conf.user (moderators conf) then
|
||||
let del =
|
||||
match p_getenv conf.env "d" with
|
||||
| Some "" | None -> false
|
||||
| Some _ -> true
|
||||
in
|
||||
if set_validator conf pos then (
|
||||
if del then forum_del conf pos;
|
||||
print_valid_ok conf (Some pos) del)
|
||||
else print_forum_headers conf base
|
||||
else print_forum_headers conf base
|
||||
| None -> print_forum_headers conf base
|
||||
|
||||
let print_valid conf base =
|
||||
match p_getenv conf.env "p" with
|
||||
| Some pos -> valid_forum_message conf base (MF.pos_of_string pos)
|
||||
| None -> print_forum_headers conf base
|
||||
|
||||
let print conf base =
|
||||
let r =
|
||||
match p_getenv conf.env "p" with
|
||||
| Some pos -> get_message conf (MF.pos_of_string pos)
|
||||
| None -> None
|
||||
in
|
||||
print_forum_message conf base r None
|
||||
|
||||
let print_add_ok conf base =
|
||||
let mess =
|
||||
let time = Util.sprintf_today conf in
|
||||
let ident = String.trim (get conf "Ident") in
|
||||
let email = String.trim (get conf "Email") in
|
||||
let subject = String.trim (get conf "Subject") in
|
||||
let text = Gutil.trim_trailing_spaces (get1 conf "Text") in
|
||||
{
|
||||
m_time = (time :> string);
|
||||
m_date = Dtext "";
|
||||
m_hour = "";
|
||||
m_waiting = false;
|
||||
m_from = "";
|
||||
m_ident = ident;
|
||||
m_wizard = "";
|
||||
m_friend = "";
|
||||
m_email = email;
|
||||
m_access = "";
|
||||
m_subject = subject;
|
||||
m_wiki = "";
|
||||
m_text = text;
|
||||
}
|
||||
in
|
||||
if not (can_post conf) then Hutil.incorrect_request conf
|
||||
else if match p_getenv conf.env "visu" with Some _ -> true | None -> false
|
||||
then visualize conf base mess
|
||||
else if mess.m_ident = "" || mess.m_text = "" then print conf base
|
||||
else
|
||||
let title _ =
|
||||
transl conf "message added"
|
||||
|> Utf8.capitalize_fst |> Output.print_sstring conf
|
||||
in
|
||||
let mods = moderators conf in
|
||||
forum_add conf base (mods <> []) mess;
|
||||
Hutil.header conf title;
|
||||
Hutil.print_link_to_welcome conf true;
|
||||
if mods <> [] then (
|
||||
Output.print_sstring conf "<p>";
|
||||
transl conf "this forum is moderated"
|
||||
|> Utf8.capitalize_fst |> Output.print_sstring conf;
|
||||
Output.print_sstring conf ". ";
|
||||
transl conf "your message is waiting for validation"
|
||||
|> Utf8.capitalize_fst |> Output.print_sstring conf;
|
||||
Output.print_sstring conf ".</p>");
|
||||
Output.print_sstring conf {|<a href="|};
|
||||
Output.print_string conf (commd conf);
|
||||
Output.print_sstring conf {|m=FORUM" id="reference">|};
|
||||
transl conf "database forum"
|
||||
|> Utf8.capitalize_fst |> Output.print_sstring conf;
|
||||
Output.print_sstring conf {|</a> |};
|
||||
Hutil.trailer conf;
|
||||
Output.print_sstring conf
|
||||
(Printf.sprintf
|
||||
{|<script>
|
||||
if (document.title == "%s") {
|
||||
document.getElementById("reference").focus();
|
||||
}
|
||||
</script>|}
|
||||
(transl conf "message added" |> Utf8.capitalize_fst))
|
||||
|
||||
let print_add conf base = print conf base
|
||||
|
||||
let delete_forum_message conf base pos =
|
||||
match get_message conf pos with
|
||||
| Some (a, m, _, _) ->
|
||||
if
|
||||
a && conf.wizard && conf.user <> "" && m.m_wizard = conf.user
|
||||
&& passwd_in_file conf "wizard"
|
||||
|| conf.manitou || conf.supervisor
|
||||
then (
|
||||
forum_del conf pos;
|
||||
print_del_ok conf (find_next_pos conf pos))
|
||||
else print_forum_headers conf base
|
||||
| None -> print_forum_headers conf base
|
||||
|
||||
let print_del conf base =
|
||||
match p_getenv conf.env "p" with
|
||||
| Some pos -> delete_forum_message conf base (MF.pos_of_string pos)
|
||||
| None -> print_forum_headers conf base
|
||||
|
||||
(* access switch *)
|
||||
|
||||
let access_switch_forum_message conf base pos =
|
||||
match get_message conf pos with
|
||||
| Some (a, m, _, _) ->
|
||||
if
|
||||
(a && conf.wizard && conf.user <> "" && m.m_wizard = conf.user
|
||||
&& passwd_in_file conf "wizard"
|
||||
|| conf.manitou || conf.supervisor)
|
||||
&& set_access conf pos
|
||||
then print_forum_message conf base (get_message conf pos) None
|
||||
else print_forum_headers conf base
|
||||
| None -> print_forum_headers conf base
|
||||
|
||||
let print_access_switch conf base =
|
||||
match p_getenv conf.env "p" with
|
||||
| Some pos -> access_switch_forum_message conf base (MF.pos_of_string pos)
|
||||
| None -> print_forum_headers conf base
|
||||
|
||||
(* searching *)
|
||||
|
||||
let search_text conf base s =
|
||||
let s = if s = "" then " " else s in
|
||||
let fname = forum_file conf in
|
||||
match try Some (MF.open_in fname) with Sys_error _ -> None with
|
||||
| Some ic -> (
|
||||
let case_sens = p_getenv conf.env "c" = Some "on" in
|
||||
let rec loop () =
|
||||
let pos = MF.rpos_in ic in
|
||||
match read_message conf ic with
|
||||
| Some (m, accessible) ->
|
||||
if
|
||||
accessible
|
||||
&& List.exists (in_text case_sens s)
|
||||
[ m.m_ident; m.m_subject; m.m_time; m.m_text ]
|
||||
then Some (m, pos)
|
||||
else loop ()
|
||||
| None -> None
|
||||
in
|
||||
(match p_getenv conf.env "p" with
|
||||
| Some pos ->
|
||||
let pos = MF.pos_of_string pos in
|
||||
(try MF.rseek_in ic pos with Sys_error _ -> ());
|
||||
let _ = read_message conf ic in
|
||||
()
|
||||
| None -> ());
|
||||
let messo = loop () in
|
||||
let next_pos = MF.rpos_in ic in
|
||||
MF.close_in ic;
|
||||
match messo with
|
||||
| Some (mess, pos) ->
|
||||
let r = Some (true, mess, pos, next_pos) in
|
||||
print_forum_message conf base r (Some s)
|
||||
| None -> print_forum_headers conf base)
|
||||
| None -> print_forum_headers conf base
|
||||
|
||||
let print_search conf base =
|
||||
match try Some (List.assoc "s" conf.env) with Not_found -> None with
|
||||
| Some s -> search_text conf base (Mutil.gen_decode false s)
|
||||
| None -> print_forum_headers conf base
|
||||
37
plugins/forum/plugin_forum.cppo.ml
Normal file
37
plugins/forum/plugin_forum.cppo.ml
Normal file
@ -0,0 +1,37 @@
|
||||
module Forum = struct
|
||||
#include "forum.ml"
|
||||
end
|
||||
module ForumDisplay = struct
|
||||
#include "forumDisplay.ml"
|
||||
end
|
||||
|
||||
open Geneweb
|
||||
open Config
|
||||
|
||||
let ns = "forum"
|
||||
|
||||
let wrapper fn conf base =
|
||||
if List.assoc_opt "disable_forum" conf.base_env <> Some "yes" then
|
||||
fn conf base
|
||||
else Hutil.incorrect_request conf;
|
||||
true
|
||||
|
||||
let w_base =
|
||||
let none conf =
|
||||
Hutil.incorrect_request conf ;
|
||||
true
|
||||
in
|
||||
Gwd_lib.Request.w_base ~none
|
||||
|
||||
let () =
|
||||
Secure.add_assets !Gwd_lib.GwdPlugin.assets ;
|
||||
Gwd_lib.GwdPlugin.register ~ns
|
||||
[ "FORUM", (fun _assets -> w_base @@ wrapper ForumDisplay.print)
|
||||
; "FORUM_ADD", (fun _assets -> w_base @@ wrapper ForumDisplay.print_add)
|
||||
; "FORUM_ADD_OK", (fun _assets -> w_base @@ wrapper ForumDisplay.print_add_ok)
|
||||
; "FORUM_DEL", (fun _assets -> w_base @@ wrapper ForumDisplay.print_del)
|
||||
; "FORUM_P_P", (fun _assets -> w_base @@ wrapper ForumDisplay.print_access_switch)
|
||||
; "FORUM_SEARCH", (fun _assets -> w_base @@ wrapper ForumDisplay.print_search)
|
||||
; "FORUM_VAL", (fun _assets -> w_base @@ wrapper ForumDisplay.print_valid)
|
||||
; "FORUM_VIEW", (fun _assets -> w_base @@ wrapper ForumDisplay.print)
|
||||
]
|
||||
1
plugins/gwxjg/META
Normal file
1
plugins/gwxjg/META
Normal file
@ -0,0 +1 @@
|
||||
depends:jingoo
|
||||
281
plugins/gwxjg/README.MD
Normal file
281
plugins/gwxjg/README.MD
Normal file
@ -0,0 +1,281 @@
|
||||
# gwxjg
|
||||
|
||||
`gwxjg` means GeneWeb x Jingoo. This package translate data from Geneweb
|
||||
structure to Jingoo's type system. Below, see a quick reference of which
|
||||
structures and which fields are accessible from a Jingoo template.
|
||||
|
||||
If you (approximately) know how to read OCaml code, the best is to read
|
||||
[Data module](data.ml), where everything is defined.
|
||||
|
||||
Alternatively, here is a simplified view of what you get when using `gwxjg`
|
||||
|
||||
## boolean
|
||||
|
||||
Either `true` or `false`.
|
||||
|
||||
## burial
|
||||
|
||||
- `type`: [burial type]
|
||||
- `date`: [date]
|
||||
|
||||
## burial type
|
||||
|
||||
A [burial type] is `"Buried"` or `"Cremated"`
|
||||
|
||||
## calendar
|
||||
|
||||
A [calendar] is one of these [string]:
|
||||
- `"Dgregorian"`
|
||||
- `"Djulian"`
|
||||
- `"Dfrench"`
|
||||
- `"Dhebrew"`
|
||||
|
||||
## date
|
||||
|
||||
- `calendar`: [calendar]
|
||||
- `d2`: [date]
|
||||
- `day`: [int]
|
||||
- `month`: [int]
|
||||
- `prec`: [prec]
|
||||
- `year`: [int]
|
||||
|
||||
## death
|
||||
|
||||
- `date` : [date]
|
||||
- `death_reason`: [death reason]
|
||||
|
||||
## death reason
|
||||
|
||||
A [death reason] is one of these [string]:
|
||||
- `"Killed"`
|
||||
- `"Murdered"`
|
||||
- `"Executed"`
|
||||
- `"Disappeared"`
|
||||
- `"Unspecified"`
|
||||
- `"DeadYoung"`
|
||||
- `"DeadDontKnowWhen"`
|
||||
- `"DontKnowIfDead"`
|
||||
- `"OfCourseDead"`
|
||||
|
||||
## event
|
||||
|
||||
- `date`: [date]
|
||||
- `kind`: [event kind]
|
||||
- `name`: [string]
|
||||
- `note`: [string]
|
||||
- `place`: [place]
|
||||
- `spouse`: [person]
|
||||
- `src`: [string]
|
||||
- `witnesses`: [witness] [list]
|
||||
|
||||
## event kind
|
||||
|
||||
A [event kind] is either *free text* or one of these [string]:
|
||||
- `"EPERS_BIRTH"`
|
||||
- `"EPERS_BAPTISM"`
|
||||
- `"EPERS_DEATH"`
|
||||
- `"EPERS_BURIAL"`
|
||||
- `"EPERS_CREMATION"`
|
||||
- `"EPERS_ACCOMPLISHMENT"`
|
||||
- `"EPERS_ACQUISITION"`
|
||||
- `"EPERS_ADHESION"`
|
||||
- `"EPERS_BAPTISMLDS"`
|
||||
- `"EPERS_BARMITZVAH"`
|
||||
- `"EPERS_BATMITZVAH"`
|
||||
- `"EPERS_BENEDICTION"`
|
||||
- `"EPERS_CHANGENAME"`
|
||||
- `"EPERS_CIRCUMCISION"`
|
||||
- `"EPERS_CONFIRMATION"`
|
||||
- `"EPERS_CONFIRMATIONLDS"`
|
||||
- `"EPERS_DECORATION"`
|
||||
- `"EPERS_DEMOBILISATIONMILITAIRE"`
|
||||
- `"EPERS_DIPLOMA"`
|
||||
- `"EPERS_DISTINCTION"`
|
||||
- `"EPERS_DOTATION"`
|
||||
- `"EPERS_DOTATIONLDS"`
|
||||
- `"EPERS_EDUCATION"`
|
||||
- `"EPERS_ELECTION"`
|
||||
- `"EPERS_EMIGRATION"`
|
||||
- `"EPERS_EXCOMMUNICATION"`
|
||||
- `"EPERS_FAMILYLINKLDS"`
|
||||
- `"EPERS_FIRSTCOMMUNION"`
|
||||
- `"EPERS_FUNERAL"`
|
||||
- `"EPERS_GRADUATE"`
|
||||
- `"EPERS_HOSPITALISATION"`
|
||||
- `"EPERS_ILLNESS"`
|
||||
- `"EPERS_IMMIGRATION"`
|
||||
- `"EPERS_LISTEPASSENGER"`
|
||||
- `"EPERS_MILITARYDISTINCTION"`
|
||||
- `"EPERS_MILITARYPROMOTION"`
|
||||
- `"EPERS_MILITARYSERVICE"`
|
||||
- `"EPERS_MOBILISATIONMILITAIRE"`
|
||||
- `"EPERS_NATURALISATION"`
|
||||
- `"EPERS_OCCUPATION"`
|
||||
- `"EPERS_ORDINATION"`
|
||||
- `"EPERS_PROPERTY"`
|
||||
- `"EPERS_RECENSEMENT"`
|
||||
- `"EPERS_RESIDENCE"`
|
||||
- `"EPERS_RETIRED"`
|
||||
- `"EPERS_SCELLENTCHILDLDS"`
|
||||
- `"EPERS_SCELLENTPARENTLDS"`
|
||||
- `"EPERS_SCELLENTSPOUSELDS"`
|
||||
- `"EPERS_VENTEBIEN"`
|
||||
- `"EPERS_WILL"`
|
||||
- `"EFAM_MARRIAGE"`
|
||||
- `"EFAM_NO_MARRIAGE"`
|
||||
- `"EFAM_NO_MENTION"`
|
||||
- `"EFAM_ENGAGE"`
|
||||
- `"EFAM_DIVORCE"`
|
||||
- `"EFAM_SEPARATED"`
|
||||
- `"EFAM_ANNULATION"`
|
||||
- `"EFAM_MARRIAGE_BANN"`
|
||||
- `"EFAM_MARRIAGE_CONTRACT"`
|
||||
- `"EFAM_MARRIAGE_LICENSE"`
|
||||
- `"EFAM_PACS"`
|
||||
- `"EFAM_RESIDENCE"`
|
||||
|
||||
## family
|
||||
|
||||
- `divorce_date`: [date]
|
||||
- `children`: [person] [list]
|
||||
- `father`: [person]
|
||||
- `events`: [event] [list]
|
||||
- `ifam`: [string]
|
||||
- `marriage_date`: [date]
|
||||
- `marriage_place`: [place]
|
||||
- `marriage_note`: [string]
|
||||
- `marriage_source`: [string]
|
||||
- `mother`: [person]
|
||||
- `origin_file`: [string]
|
||||
- `relation`: [relation]
|
||||
- `separation`: [separation]
|
||||
- `spouse`: [person]
|
||||
- `witnesses`: [persons] [list]
|
||||
|
||||
## float
|
||||
|
||||
A floating point number.
|
||||
|
||||
## int
|
||||
|
||||
An integer.
|
||||
|
||||
## list
|
||||
|
||||
A sequence of zero or more items.
|
||||
|
||||
## person
|
||||
|
||||
- `access`: [string]
|
||||
- `baptism_date`: [date]
|
||||
- `baptism_place`: [place]
|
||||
- `birth_date`: [date]
|
||||
- `birth_place`: [place]
|
||||
- `burial`: [burial]
|
||||
- `burial_place`: [string]
|
||||
- `children`: [person] [list]
|
||||
- `cremation_place`: [place]
|
||||
- `consanguinity`: [float]
|
||||
- `dates`: [string]
|
||||
- `death`: [death]
|
||||
- `death_place`: [place]
|
||||
- `digest`: [string]
|
||||
- `events`: [event] [list]
|
||||
- `families`: [family] [list]
|
||||
- `father`: [person]
|
||||
- `first_name`: [string]
|
||||
- `first_name_aliases`: [string] [list]
|
||||
- `first_name_key`: [string]
|
||||
- `first_name_key_val`: [string]
|
||||
- `half_siblings`: [person] [list]
|
||||
- `iper`: [string]
|
||||
- `is_birthday`: [boolean]
|
||||
- `is_visible_for_visitors`: [boolean]
|
||||
- `linked_page`: [string]
|
||||
- `mother`: [person]
|
||||
- `occ`: [int]
|
||||
- `occupation`: [string]
|
||||
- `parents`: [family]
|
||||
- `public_name`: [string]
|
||||
- `qualifier`: [string]
|
||||
- `qualifiers`: [string] [list]
|
||||
- `relations`: [person] [list]
|
||||
- `related`: [related] list
|
||||
- `sex`: [int]
|
||||
- `siblings`: [person] [list]
|
||||
- `sosa`: [string]
|
||||
- `sources`: [string]
|
||||
- `spouses`: [person] [list]
|
||||
- `surname`: [string]
|
||||
- `surname_aliases`: [string] [list]
|
||||
- `surname_key`: [string]
|
||||
- `surname_key_val`: [string]
|
||||
- `titles`: [title] [list]
|
||||
|
||||
## place
|
||||
|
||||
For now, [place] is an alias for [string],
|
||||
but it will eventually become a real data structure.
|
||||
|
||||
## prec
|
||||
|
||||
A [prec] is one of these [string]:
|
||||
- `"sure"`
|
||||
- `"about"`
|
||||
- `"maybe"`
|
||||
- `"before"`
|
||||
- `"after"`
|
||||
- `"oryear"`
|
||||
- `"yearint"`
|
||||
|
||||
## related
|
||||
|
||||
A related is a [person] with these extra fields:
|
||||
- `sources`: [string]
|
||||
- `kind`: [related kind]
|
||||
|
||||
## related kind
|
||||
|
||||
A [related kind] is one of these [string]:
|
||||
- `"ADOPTION"`
|
||||
- `"RECOGNITION"`
|
||||
- `"CANDIDATEPARENT"`
|
||||
- `"GODPARENT"`
|
||||
- `"FOSTERPARENT"`
|
||||
|
||||
## string
|
||||
|
||||
This is just text.
|
||||
|
||||
## title
|
||||
|
||||
- `ident`: [string]
|
||||
- `name`: [string]
|
||||
- `place`: [place]
|
||||
- `date_start`: [date]
|
||||
- `date_end`: [date]
|
||||
- `nth`: [int]
|
||||
|
||||
|
||||
## witness
|
||||
|
||||
[boolean]: #boolean
|
||||
[burial]: #burial
|
||||
[burial type]: #burial-type
|
||||
[calendar]: #calendar
|
||||
[date]: #date
|
||||
[death]: #death
|
||||
[death reason]: #death
|
||||
[event]: #event
|
||||
[family]: #family
|
||||
[float]: #float
|
||||
[int]: #int
|
||||
[list]: #list
|
||||
[person]: #person
|
||||
[place]: #place
|
||||
[prec]: #prec
|
||||
[related]: #related
|
||||
[related kind]: #related-kind
|
||||
[string]: #string
|
||||
[title]: #title
|
||||
[witness]: #witness
|
||||
24
plugins/gwxjg/dune
Normal file
24
plugins/gwxjg/dune
Normal file
@ -0,0 +1,24 @@
|
||||
(alias
|
||||
(name plugin)
|
||||
(deps
|
||||
(file META)
|
||||
plugin_gwxjg.cmxs))
|
||||
|
||||
(ocamllex gwxjg_lexicon_parser)
|
||||
|
||||
(library
|
||||
(name plugin_gwxjg_lib)
|
||||
(public_name geneweb.plugin_gwxjg_lib)
|
||||
(libraries unix geneweb jingoo)
|
||||
(flags
|
||||
(:standard -w -42-40))
|
||||
(modules gwxjg_ezgw gwxjg_data gwxjg_trans gwxjg_lexicon_parser))
|
||||
|
||||
(executable
|
||||
(name plugin_gwxjg)
|
||||
(libraries geneweb.gwd_lib plugin_gwxjg_lib)
|
||||
(embed_in_plugin_libraries plugin_gwxjg_lib)
|
||||
(flags -linkall)
|
||||
(modes
|
||||
(native plugin))
|
||||
(modules plugin_gwxjg))
|
||||
1336
plugins/gwxjg/gwxjg_data.ml
Normal file
1336
plugins/gwxjg/gwxjg_data.ml
Normal file
File diff suppressed because it is too large
Load Diff
291
plugins/gwxjg/gwxjg_ezgw.ml
Normal file
291
plugins/gwxjg/gwxjg_ezgw.ml
Normal file
@ -0,0 +1,291 @@
|
||||
(* /!\ This is mostly copy/paste of the Perso module /!\ *)
|
||||
(* Sync with perso from ed7525bac *)
|
||||
open Geneweb
|
||||
open Config
|
||||
open Def
|
||||
open Gwdb
|
||||
open Util
|
||||
|
||||
type fam = ifam * family * (iper * iper * iper) * bool
|
||||
type rel = relation * person option
|
||||
|
||||
type env = {
|
||||
all_gp : Perso.generation_person list option;
|
||||
baseprefix : string option;
|
||||
desc_level_table : (int array * int array) Lazy.t option;
|
||||
desc_mark : bool array ref option;
|
||||
f_link : bool option;
|
||||
fam : fam option;
|
||||
fam_link : fam option;
|
||||
p_link : bool option;
|
||||
prev_fam : fam option;
|
||||
sosa : (iper * (Sosa.t * person) option) list ref option;
|
||||
sosa_ref : person option Lazy.t option;
|
||||
src : string option;
|
||||
}
|
||||
|
||||
let conf_w_baseprefix conf env =
|
||||
match env.baseprefix with
|
||||
| Some baseprefix -> { conf with command = baseprefix }
|
||||
| None -> conf
|
||||
|
||||
let empty =
|
||||
{
|
||||
all_gp = None;
|
||||
baseprefix = None;
|
||||
desc_level_table = None;
|
||||
desc_mark = None;
|
||||
fam = None;
|
||||
f_link = None;
|
||||
fam_link = None;
|
||||
p_link = None;
|
||||
prev_fam = None;
|
||||
sosa = None;
|
||||
sosa_ref = None;
|
||||
src = None;
|
||||
}
|
||||
|
||||
let env = empty
|
||||
let get_env x = match x with Some x -> x | None -> raise Not_found
|
||||
|
||||
let sex_of_index = function
|
||||
| 0 -> Male
|
||||
| 1 -> Female
|
||||
| 2 -> Neuter
|
||||
| _ -> raise (Invalid_argument "sex_of_index")
|
||||
|
||||
module Person = struct
|
||||
let children base p = Gwdb.children_of_p base p
|
||||
|
||||
let consanguinity p =
|
||||
let c = get_consang p in
|
||||
if c != Adef.fix (-1) && c >= Adef.fix_of_float 0.0001 then
|
||||
Adef.float_of_fix c
|
||||
else 0.
|
||||
|
||||
let dates conf base p = DateDisplay.short_dates_text conf base p
|
||||
let death p = get_death p
|
||||
|
||||
(* TODOWHY: should it be Event.sorted_events or can it be just Event.events? *)
|
||||
let events = Event.sorted_events
|
||||
let first_name base p = p_first_name base p
|
||||
|
||||
let history_file base p =
|
||||
let fn = sou base (get_first_name p) in
|
||||
let sn = sou base (get_surname p) in
|
||||
let occ = get_occ p in
|
||||
HistoryDiff.history_file fn sn occ
|
||||
|
||||
let is_accessible_by_key conf base p =
|
||||
Util.accessible_by_key conf base p (p_first_name base p) (p_surname base p)
|
||||
|
||||
let linked_page conf base p s =
|
||||
let db = Gwdb.read_nldb base in
|
||||
let db = Notes.merge_possible_aliases conf db in
|
||||
let key =
|
||||
let fn = Name.lower (sou base (get_first_name p)) in
|
||||
let sn = Name.lower (sou base (get_surname p)) in
|
||||
(fn, sn, get_occ p)
|
||||
in
|
||||
List.fold_left (Perso.linked_page_text conf base p s key) (Adef.safe "") db
|
||||
|
||||
let note conf base p = if not conf.no_note then sou base (get_notes p) else ""
|
||||
|
||||
let related conf base p =
|
||||
List.sort (fun (c1, _) (c2, _) ->
|
||||
let mk_date c =
|
||||
match Date.od_of_cdate (get_baptism c) with
|
||||
| None -> Date.od_of_cdate (get_birth c)
|
||||
| x -> x
|
||||
in
|
||||
match (mk_date c1, mk_date c2) with
|
||||
| Some d1, Some d2 -> Date.compare_date d1 d2
|
||||
| _ -> -1)
|
||||
@@ List.fold_left
|
||||
(fun list ic ->
|
||||
let c = pget conf base ic in
|
||||
List.fold_left
|
||||
(fun acc r ->
|
||||
match (r.r_fath, r.r_moth) with
|
||||
| Some ip, _ when ip = get_iper p -> (c, r) :: acc
|
||||
| _, Some ip when ip = get_iper p -> (c, r) :: acc
|
||||
| _ -> acc)
|
||||
list (get_rparents c))
|
||||
[]
|
||||
(List.sort_uniq compare (get_related p))
|
||||
|
||||
(* Why isnt this already unique? *)
|
||||
let relations p = List.sort_uniq compare (get_related p)
|
||||
|
||||
let siblings base p =
|
||||
match get_parents p with
|
||||
| Some ifam ->
|
||||
let ip = get_iper p in
|
||||
Array.fold_right
|
||||
(fun i acc -> if i <> ip then i :: acc else acc)
|
||||
(get_children (foi base ifam))
|
||||
[]
|
||||
| None -> []
|
||||
|
||||
let half_siblings base p =
|
||||
match get_parents p with
|
||||
| Some ifam ->
|
||||
let ip = get_iper p in
|
||||
let f = foi base ifam in
|
||||
let filter (acc : iper list) i =
|
||||
if i = ifam then acc
|
||||
else
|
||||
Array.fold_right
|
||||
(fun i acc -> if i <> ip then i :: acc else acc)
|
||||
(get_children (foi base i))
|
||||
acc
|
||||
in
|
||||
let hs =
|
||||
let ifath = get_father f in
|
||||
if ifath = dummy_iper then []
|
||||
else Array.fold_left filter [] (get_family @@ poi base ifath)
|
||||
in
|
||||
let imoth = get_mother f in
|
||||
if imoth = dummy_iper then hs
|
||||
else Array.fold_left filter hs (get_family @@ poi base imoth)
|
||||
| None -> []
|
||||
|
||||
let sex p = index_of_sex (get_sex p)
|
||||
let surname base p = p_surname base p
|
||||
end
|
||||
|
||||
module Family = struct
|
||||
let children (_, fam, _, _) = get_children fam
|
||||
|
||||
let divorce_date (_, fam, _, auth) =
|
||||
match get_divorce fam with
|
||||
| Divorced d when auth -> Date.od_of_cdate d
|
||||
| _ -> None
|
||||
|
||||
let events (_, fam, (_, _, isp), auth) =
|
||||
if auth then
|
||||
List.fold_right
|
||||
(fun evt fam_fevents ->
|
||||
let name = Event.Fevent evt.efam_name in
|
||||
let date = evt.efam_date in
|
||||
let place = evt.efam_place in
|
||||
let note = evt.efam_note in
|
||||
let src = evt.efam_src in
|
||||
let wl = evt.efam_witnesses in
|
||||
let x = (name, date, place, note, src, wl, Some isp) in
|
||||
x :: fam_fevents)
|
||||
(get_fevents fam) []
|
||||
else []
|
||||
|
||||
let father (_, _, (ifath, _, _), _) = ifath
|
||||
let ifam (ifam, _, _, _) = string_of_ifam ifam
|
||||
|
||||
let marriage_date (_, fam, (_, _, _), auth) =
|
||||
if auth then Date.od_of_cdate (get_marriage fam) else None
|
||||
|
||||
let marriage_place (_, fam, _, _) = get_marriage_place fam
|
||||
|
||||
let marriage_note (_, fam, _, auth) =
|
||||
if auth then get_marriage_note fam else Gwdb.empty_string
|
||||
|
||||
let marriage_source (_, fam, _, auth) =
|
||||
if auth then get_marriage_src fam else Gwdb.empty_string
|
||||
|
||||
let mother (_, _, (_, imoth, _), _) = imoth
|
||||
|
||||
let note conf base (_, fam, _, auth) =
|
||||
if auth && not conf.no_note then sou base (get_comment fam) else ""
|
||||
|
||||
let origin_file conf base (_, fam, _, _) =
|
||||
if conf.wizard then sou base (get_origin_file fam) else ""
|
||||
|
||||
let spouse_iper (_, _, (_, _, ip), _) = ip
|
||||
let witnesses (_, fam, _, auth) = if auth then get_witnesses fam else [||]
|
||||
|
||||
let sources base (_, fam, _, auth) =
|
||||
if auth then sou base (get_fsources fam) else ""
|
||||
end
|
||||
|
||||
module Event = struct
|
||||
let name conf base (n, _, _, _, _, _, _) =
|
||||
match n with
|
||||
| Event.Pevent name -> Util.string_of_pevent_name conf base name
|
||||
| Event.Fevent name -> Util.string_of_fevent_name conf base name
|
||||
|
||||
let kind (n, _, _, _, _, _, _) =
|
||||
match n with
|
||||
| Event.Pevent Epers_Birth -> "EPERS_BIRTH"
|
||||
| Pevent Epers_Baptism -> "EPERS_BAPTISM"
|
||||
| Pevent Epers_Death -> "EPERS_DEATH"
|
||||
| Pevent Epers_Burial -> "EPERS_BURIAL"
|
||||
| Pevent Epers_Cremation -> "EPERS_CREMATION"
|
||||
| Pevent Epers_Accomplishment -> "EPERS_ACCOMPLISHMENT"
|
||||
| Pevent Epers_Acquisition -> "EPERS_ACQUISITION"
|
||||
| Pevent Epers_Adhesion -> "EPERS_ADHESION"
|
||||
| Pevent Epers_BaptismLDS -> "EPERS_BAPTISMLDS"
|
||||
| Pevent Epers_BarMitzvah -> "EPERS_BARMITZVAH"
|
||||
| Pevent Epers_BatMitzvah -> "EPERS_BATMITZVAH"
|
||||
| Pevent Epers_Benediction -> "EPERS_BENEDICTION"
|
||||
| Pevent Epers_ChangeName -> "EPERS_CHANGENAME"
|
||||
| Pevent Epers_Circumcision -> "EPERS_CIRCUMCISION"
|
||||
| Pevent Epers_Confirmation -> "EPERS_CONFIRMATION"
|
||||
| Pevent Epers_ConfirmationLDS -> "EPERS_CONFIRMATIONLDS"
|
||||
| Pevent Epers_Decoration -> "EPERS_DECORATION"
|
||||
| Pevent Epers_DemobilisationMilitaire -> "EPERS_DEMOBILISATIONMILITAIRE"
|
||||
| Pevent Epers_Diploma -> "EPERS_DIPLOMA"
|
||||
| Pevent Epers_Distinction -> "EPERS_DISTINCTION"
|
||||
| Pevent Epers_Dotation -> "EPERS_DOTATION"
|
||||
| Pevent Epers_DotationLDS -> "EPERS_DOTATIONLDS"
|
||||
| Pevent Epers_Education -> "EPERS_EDUCATION"
|
||||
| Pevent Epers_Election -> "EPERS_ELECTION"
|
||||
| Pevent Epers_Emigration -> "EPERS_EMIGRATION"
|
||||
| Pevent Epers_Excommunication -> "EPERS_EXCOMMUNICATION"
|
||||
| Pevent Epers_FamilyLinkLDS -> "EPERS_FAMILYLINKLDS"
|
||||
| Pevent Epers_FirstCommunion -> "EPERS_FIRSTCOMMUNION"
|
||||
| Pevent Epers_Funeral -> "EPERS_FUNERAL"
|
||||
| Pevent Epers_Graduate -> "EPERS_GRADUATE"
|
||||
| Pevent Epers_Hospitalisation -> "EPERS_HOSPITALISATION"
|
||||
| Pevent Epers_Illness -> "EPERS_ILLNESS"
|
||||
| Pevent Epers_Immigration -> "EPERS_IMMIGRATION"
|
||||
| Pevent Epers_ListePassenger -> "EPERS_LISTEPASSENGER"
|
||||
| Pevent Epers_MilitaryDistinction -> "EPERS_MILITARYDISTINCTION"
|
||||
| Pevent Epers_MilitaryPromotion -> "EPERS_MILITARYPROMOTION"
|
||||
| Pevent Epers_MilitaryService -> "EPERS_MILITARYSERVICE"
|
||||
| Pevent Epers_MobilisationMilitaire -> "EPERS_MOBILISATIONMILITAIRE"
|
||||
| Pevent Epers_Naturalisation -> "EPERS_NATURALISATION"
|
||||
| Pevent Epers_Occupation -> "EPERS_OCCUPATION"
|
||||
| Pevent Epers_Ordination -> "EPERS_ORDINATION"
|
||||
| Pevent Epers_Property -> "EPERS_PROPERTY"
|
||||
| Pevent Epers_Recensement -> "EPERS_RECENSEMENT"
|
||||
| Pevent Epers_Residence -> "EPERS_RESIDENCE"
|
||||
| Pevent Epers_Retired -> "EPERS_RETIRED"
|
||||
| Pevent Epers_ScellentChildLDS -> "EPERS_SCELLENTCHILDLDS"
|
||||
| Pevent Epers_ScellentParentLDS -> "EPERS_SCELLENTPARENTLDS"
|
||||
| Pevent Epers_ScellentSpouseLDS -> "EPERS_SCELLENTSPOUSELDS"
|
||||
| Pevent Epers_VenteBien -> "EPERS_VENTEBIEN"
|
||||
| Pevent Epers_Will -> "EPERS_WILL"
|
||||
| Fevent Efam_Marriage -> "EFAM_MARRIAGE"
|
||||
| Fevent Efam_NoMarriage -> "EFAM_NO_MARRIAGE"
|
||||
| Fevent Efam_NoMention -> "EFAM_NO_MENTION"
|
||||
| Fevent Efam_Engage -> "EFAM_ENGAGE"
|
||||
| Fevent Efam_Divorce -> "EFAM_DIVORCE"
|
||||
| Fevent Efam_Separated -> "EFAM_SEPARATED"
|
||||
| Fevent Efam_Annulation -> "EFAM_ANNULATION"
|
||||
| Fevent Efam_MarriageBann -> "EFAM_MARRIAGE_BANN"
|
||||
| Fevent Efam_MarriageContract -> "EFAM_MARRIAGE_CONTRACT"
|
||||
| Fevent Efam_MarriageLicense -> "EFAM_MARRIAGE_LICENSE"
|
||||
| Fevent Efam_PACS -> "EFAM_PACS"
|
||||
| Fevent Efam_Residence -> "EFAM_RESIDENCE"
|
||||
| Pevent (Epers_Name _) -> "EPERS"
|
||||
| Fevent (Efam_Name _) -> "EFAM"
|
||||
|
||||
let date (_, d, _, _, _, _, _) = Date.od_of_cdate d
|
||||
let place base (_, _, p, _, _, _, _) = sou base p
|
||||
|
||||
let note conf base (_, _, _, n, _, _, _) =
|
||||
if conf.no_note then "" else sou base n
|
||||
|
||||
let src base (_, _, _, _, s, _, _) = sou base s
|
||||
let witnesses (_, _, _, _, _, w, _) = w
|
||||
let spouse_opt (_, _, _, _, _, _, isp) = isp
|
||||
end
|
||||
143
plugins/gwxjg/gwxjg_lexicon_parser.mll
Normal file
143
plugins/gwxjg/gwxjg_lexicon_parser.mll
Normal file
@ -0,0 +1,143 @@
|
||||
{
|
||||
|
||||
type i18n_expr =
|
||||
| Arg of string
|
||||
| Str of string
|
||||
| Elision of string * string
|
||||
| Declension of char * string
|
||||
|
||||
let flush buffer acc =
|
||||
let acc = match Buffer.contents buffer with
|
||||
| "" -> acc
|
||||
| x -> Str x :: acc in
|
||||
Buffer.clear buffer ;
|
||||
acc
|
||||
|
||||
let need_split = function
|
||||
| "!languages"
|
||||
| "(date)"
|
||||
| "(french revolution month)"
|
||||
| "(hebrew month)"
|
||||
| "(month)"
|
||||
| "(week day)"
|
||||
| "a 2nd cousin"
|
||||
| "a 3rd cousin"
|
||||
| "a cousin"
|
||||
| "a descendant"
|
||||
| "alive"
|
||||
| "an ancestor"
|
||||
| "and"
|
||||
| "a %s cousin"
|
||||
| "baptized"
|
||||
| "born"
|
||||
| "buried"
|
||||
| "cremated"
|
||||
| "died"
|
||||
| "died young"
|
||||
| "disappeared"
|
||||
| "engaged%t to"
|
||||
| "executed (legally killed)"
|
||||
| "grand-parents"
|
||||
| "great-grand-parents"
|
||||
| "inversion done"
|
||||
| "killed (in action)"
|
||||
| "married%t to"
|
||||
| "murdered"
|
||||
| "next sibling"
|
||||
| "nth"
|
||||
| "nth (cousin)"
|
||||
| "nth (generation)"
|
||||
| "previous sibling"
|
||||
| "relationship%t to"
|
||||
| "the spouse"
|
||||
| "would be his/her own ancestor"
|
||||
| "died at an advanced age"
|
||||
| "half siblings"
|
||||
| "(short month)"
|
||||
-> true
|
||||
| "is born after his/her child"
|
||||
| "loop in database: %s is his/her own ancestor"
|
||||
| "%t was witness after his/her death"
|
||||
| "%t was witness before his/her birth"
|
||||
| "%t's %s before his/her %s"
|
||||
| "%t witnessed the %s after his/her death"
|
||||
| "%t witnessed the %s before his/her birth"
|
||||
-> false
|
||||
| t -> String.contains t '/'
|
||||
|
||||
}
|
||||
|
||||
let lower = ['a'-'z']
|
||||
let upper = ['A'-'Z']
|
||||
let num = ['0'-'9']
|
||||
|
||||
let id = (lower | ['_']) (lower | upper | num | ['_'])*
|
||||
|
||||
let line = [^ '\n' ]+
|
||||
let eol = '\n'
|
||||
|
||||
rule p_main acc = parse
|
||||
| ' '+ (line as t) eol
|
||||
{ p_main ((t, p_lang (need_split t) [] lexbuf) :: acc) lexbuf }
|
||||
| _
|
||||
{ p_main acc lexbuf }
|
||||
| eof { acc }
|
||||
|
||||
and p_lang split acc = parse
|
||||
| ((lower | '-' )+ as lang) ':' ' '? (line as trad) eol {
|
||||
let trad =
|
||||
if split then Array.of_list @@ String.split_on_char '/' trad
|
||||
else [| trad |]
|
||||
in
|
||||
let trad =
|
||||
Array.map (fun t -> p_trad (Buffer.create 42) [] @@ Lexing.from_string t) trad
|
||||
in
|
||||
p_lang split ((lang, trad) :: acc) lexbuf
|
||||
}
|
||||
| "" { acc }
|
||||
|
||||
and p_trad buffer acc = parse
|
||||
| '%' (num as n) {
|
||||
let acc = flush buffer acc in
|
||||
p_trad buffer (Arg ("_" ^ String.make 1 n) :: acc) lexbuf
|
||||
}
|
||||
| '%' (lower as n) {
|
||||
let acc = flush buffer acc in
|
||||
p_trad buffer (Arg (String.make 1 n) :: acc) lexbuf
|
||||
}
|
||||
| ':' (lower as c) ':' '%' (num as n) {
|
||||
let acc = flush buffer acc in
|
||||
p_trad buffer (Declension (c, "_" ^ String.make 1 n) :: acc) lexbuf
|
||||
}
|
||||
| ':' (lower as c) ':' '%' (lower as n) {
|
||||
let acc = flush buffer acc in
|
||||
p_trad buffer (Declension (c, String.make 1 n) :: acc) lexbuf
|
||||
}
|
||||
| '[' ([^'|']* as s1) '|' ([^']']* as s2) ']' {
|
||||
let acc = flush buffer acc in
|
||||
p_trad buffer (Elision (s1, s2) :: acc) lexbuf
|
||||
}
|
||||
| _ as c {
|
||||
Buffer.add_char buffer c ;
|
||||
p_trad buffer acc lexbuf
|
||||
}
|
||||
| eof {
|
||||
let occ c acc =
|
||||
List.fold_left (fun sum -> function Arg x when x.[0] = c -> sum + 1 | _ -> sum) 1 acc
|
||||
in
|
||||
let rec loop acc = function
|
||||
| Arg hd :: tl ->
|
||||
let c = hd.[0] in
|
||||
if c <> '_' then
|
||||
let occ = occ c tl in
|
||||
if occ = 1
|
||||
&& not (List.exists (function Arg s -> s.[0] = c | _ -> false) acc)
|
||||
then loop (Arg hd :: acc) tl
|
||||
else loop (Arg (hd ^ string_of_int occ) :: acc) tl
|
||||
else loop (Arg hd :: acc) tl
|
||||
| hd :: tl -> loop (hd :: acc) tl
|
||||
| [] -> acc
|
||||
in
|
||||
loop [] (flush buffer acc)
|
||||
|> Array.of_list
|
||||
}
|
||||
121
plugins/gwxjg/gwxjg_trans.ml
Normal file
121
plugins/gwxjg/gwxjg_trans.ml
Normal file
@ -0,0 +1,121 @@
|
||||
module Lexicon_parser = Gwxjg_lexicon_parser
|
||||
open Jingoo
|
||||
|
||||
let fast_concat = function
|
||||
| [] -> ""
|
||||
| [ s ] -> s
|
||||
| l ->
|
||||
let b =
|
||||
Bytes.create (List.fold_left (fun acc s -> String.length s + acc) 0 l)
|
||||
in
|
||||
ignore
|
||||
@@ List.fold_left
|
||||
(fun pos s ->
|
||||
let len = String.length s in
|
||||
Bytes.unsafe_blit (Bytes.unsafe_of_string s) 0 b pos len;
|
||||
pos + len)
|
||||
0 l;
|
||||
Bytes.unsafe_to_string b
|
||||
|
||||
let args line =
|
||||
List.sort_uniq compare
|
||||
@@ List.fold_left
|
||||
(fun acc list ->
|
||||
List.fold_left
|
||||
(fun acc -> function Lexicon_parser.Arg x -> x :: acc | _ -> acc)
|
||||
acc list)
|
||||
[] line
|
||||
|
||||
let import_trad ht keyword line =
|
||||
let open Jg_types in
|
||||
let open Jg_runtime in
|
||||
Hashtbl.add ht keyword @@ fun ?(kwargs = []) i ->
|
||||
let i = if i < 0 || i >= Array.length line then 0 else i in
|
||||
let arg s = List.assoc s kwargs in
|
||||
Tstr
|
||||
(fast_concat
|
||||
@@
|
||||
let a = Array.unsafe_get line i in
|
||||
let rec loop acc i =
|
||||
if i < 0 then acc
|
||||
else
|
||||
match Array.unsafe_get a i with
|
||||
| Lexicon_parser.Str s -> loop (s :: acc) (i - 1)
|
||||
| Arg n -> loop (string_of_tvalue (arg n) :: acc) (i - 1)
|
||||
| Declension (c, n) ->
|
||||
loop ((arg n |> string_of_tvalue |> Mutil.decline c) :: acc) (i - 1)
|
||||
| Elision (s1, s2) ->
|
||||
let x =
|
||||
try unbox_string @@ arg "elision" with Not_found -> List.hd acc
|
||||
in
|
||||
if
|
||||
x <> ""
|
||||
&& Unidecode.decode
|
||||
(fun _ _ -> false)
|
||||
(fun _ -> function
|
||||
| 'A' | 'E' | 'I' | 'O' | 'U' | 'a' | 'e' | 'i' | 'o' | 'u'
|
||||
->
|
||||
true
|
||||
| _ -> false)
|
||||
(fun _ -> false)
|
||||
x 0 (String.length x)
|
||||
then loop (s2 :: acc) (i - 1)
|
||||
else loop (s1 :: acc) (i - 1)
|
||||
in
|
||||
loop [] (Array.length a - 1))
|
||||
|
||||
let default_lang = "en"
|
||||
|
||||
let find_lang lang tr =
|
||||
try List.assoc lang tr with Not_found -> List.assoc default_lang tr
|
||||
|
||||
let make_lang lexicon len lang =
|
||||
let ht = Hashtbl.create len in
|
||||
List.iter (fun (key, tr) -> import_trad ht key (find_lang lang tr)) lexicon;
|
||||
ht
|
||||
|
||||
let lexicon_files = ref []
|
||||
|
||||
let de_en_es_fi_fr_it_nl_no_pt_sv =
|
||||
lazy
|
||||
(let acc =
|
||||
List.fold_left
|
||||
(fun acc file ->
|
||||
let in_chan = open_in file in
|
||||
let lexbuf = Lexing.from_channel in_chan in
|
||||
try
|
||||
let acc = Lexicon_parser.p_main acc lexbuf in
|
||||
close_in in_chan;
|
||||
acc
|
||||
with Failure msg ->
|
||||
failwith
|
||||
(Printf.sprintf "%s line: %d" msg
|
||||
lexbuf.Lexing.lex_curr_p.Lexing.pos_lnum))
|
||||
[] !lexicon_files
|
||||
in
|
||||
let lexicon =
|
||||
let rec loop acc = function
|
||||
| [] -> acc
|
||||
| ((key, trad) as hd) :: tl ->
|
||||
let acc =
|
||||
if
|
||||
List.exists (fun (k, _) -> k = key) acc
|
||||
|| not (List.mem_assoc default_lang trad)
|
||||
then acc
|
||||
else hd :: acc
|
||||
in
|
||||
loop acc tl
|
||||
in
|
||||
loop [] acc
|
||||
in
|
||||
let len = List.length lexicon in
|
||||
( make_lang lexicon len "de",
|
||||
make_lang lexicon len "en",
|
||||
make_lang lexicon len "es",
|
||||
make_lang lexicon len "fi",
|
||||
make_lang lexicon len "fr",
|
||||
make_lang lexicon len "it",
|
||||
make_lang lexicon len "nl",
|
||||
make_lang lexicon len "no",
|
||||
make_lang lexicon len "pt",
|
||||
make_lang lexicon len "sv" ))
|
||||
1
plugins/gwxjg/plugin_gwxjg.ml
Normal file
1
plugins/gwxjg/plugin_gwxjg.ml
Normal file
@ -0,0 +1 @@
|
||||
let () = ()
|
||||
12
plugins/jingoo/dune
Normal file
12
plugins/jingoo/dune
Normal file
@ -0,0 +1,12 @@
|
||||
(alias
|
||||
(name plugin)
|
||||
(deps plugin_jingoo.cmxs))
|
||||
|
||||
(executable
|
||||
(name plugin_jingoo)
|
||||
(libraries geneweb.gwd_lib)
|
||||
(embed_in_plugin_libraries jingoo)
|
||||
(flags -linkall)
|
||||
(modes
|
||||
(native plugin))
|
||||
(modules plugin_jingoo))
|
||||
0
plugins/jingoo/plugin_jingoo.ml
Normal file
0
plugins/jingoo/plugin_jingoo.ml
Normal file
10
plugins/lib_show/dune
Normal file
10
plugins/lib_show/dune
Normal file
@ -0,0 +1,10 @@
|
||||
(alias
|
||||
(name plugin)
|
||||
(deps plugin_lib_show.cmxs))
|
||||
|
||||
(executable
|
||||
(name plugin_lib_show)
|
||||
(embed_in_plugin_libraries geneweb.def_show)
|
||||
(flags -linkall)
|
||||
(modes
|
||||
(native plugin)))
|
||||
0
plugins/lib_show/plugin_lib_show.ml
Normal file
0
plugins/lib_show/plugin_lib_show.ml
Normal file
9
plugins/no_index/dune
Normal file
9
plugins/no_index/dune
Normal file
@ -0,0 +1,9 @@
|
||||
(executable
|
||||
(name plugin_no_index)
|
||||
(libraries geneweb geneweb.gwd_lib geneweb.wserver)
|
||||
(modes
|
||||
(native plugin)))
|
||||
|
||||
(alias
|
||||
(name plugin)
|
||||
(deps plugin_no_index.cmxs))
|
||||
130
plugins/no_index/plugin_no_index.ml
Normal file
130
plugins/no_index/plugin_no_index.ml
Normal file
@ -0,0 +1,130 @@
|
||||
open Geneweb
|
||||
open Config
|
||||
open Adef
|
||||
|
||||
let ns = "no_index"
|
||||
|
||||
let url_no_index conf base pwd =
|
||||
let scratch s = Mutil.encode (Name.lower (Gwdb.sou base s)) in
|
||||
let get_a_person v =
|
||||
try
|
||||
let i = Gwdb.iper_of_string (Mutil.decode v) in
|
||||
let p = Util.pget conf base i in
|
||||
if
|
||||
(Util.is_hide_names conf p && not (Util.authorized_age conf base p))
|
||||
|| Util.is_hidden p
|
||||
then None
|
||||
else
|
||||
let f = scratch (Gwdb.get_first_name p) in
|
||||
let s = scratch (Gwdb.get_surname p) in
|
||||
let oc = string_of_int (Gwdb.get_occ p) |> Adef.encoded in
|
||||
Some (f, s, oc)
|
||||
with Failure _ -> None
|
||||
in
|
||||
let get_a_family v =
|
||||
try
|
||||
let i = Gwdb.ifam_of_string (Mutil.decode v) in
|
||||
let fam = Gwdb.foi base i in
|
||||
let p = Util.pget conf base (Gwdb.get_father fam) in
|
||||
let f = scratch (Gwdb.get_first_name p) in
|
||||
let s = scratch (Gwdb.get_surname p) in
|
||||
if
|
||||
(f : Adef.encoded_string :> string) = ""
|
||||
|| (s : Adef.encoded_string :> string) = ""
|
||||
then None
|
||||
else
|
||||
let oc = string_of_int (Gwdb.get_occ p) |> Adef.encoded in
|
||||
let u = Util.pget conf base (Gwdb.get_father fam) in
|
||||
let n =
|
||||
let rec loop k =
|
||||
if (Gwdb.get_family u).(k) = i then string_of_int k |> Adef.encoded
|
||||
else loop (k + 1)
|
||||
in
|
||||
loop 0
|
||||
in
|
||||
Some (f, s, oc, n)
|
||||
with Failure _ -> None
|
||||
in
|
||||
let env =
|
||||
let rec loop :
|
||||
(string * Adef.encoded_string) list ->
|
||||
(string * Adef.encoded_string) list = function
|
||||
| [] -> []
|
||||
| ("opt", s) :: l when (s :> string) = "no_index" -> loop l
|
||||
| ("opt", s) :: l when (s :> string) = "no_index_pwd" -> loop l
|
||||
| (("dsrc" | "escache" | "templ"), _) :: l -> loop l
|
||||
| ("i", v) :: l -> new_env "i" v (fun x -> x) l
|
||||
| ("ei", v) :: l -> new_env "ei" v (fun x -> "e" ^ x) l
|
||||
| (k, v) :: l when String.length k = 2 && k.[0] = 'i' ->
|
||||
let c = String.make 1 k.[1] in
|
||||
new_env k v (fun x -> x ^ c) l
|
||||
| (k, (v : Adef.encoded_string)) :: l
|
||||
when String.length k > 2 && k.[0] = 'e' && k.[1] = 'f' ->
|
||||
new_fam_env k v (fun x -> x ^ k) l
|
||||
| kv :: l -> kv :: loop l
|
||||
and new_env k (v : Adef.encoded_string) c l :
|
||||
(string * Adef.encoded_string) list =
|
||||
match get_a_person v with
|
||||
| Some (f, s, oc) ->
|
||||
if (oc :> string) = "0" then (c "p", f) :: (c "n", s) :: loop l
|
||||
else (c "p", f) :: (c "n", s) :: (c "oc", oc) :: loop l
|
||||
| None -> (k, v) :: loop l
|
||||
and new_fam_env k (v : Adef.encoded_string) c l =
|
||||
match get_a_family v with
|
||||
| Some (f, s, oc, n) ->
|
||||
let l = loop l in
|
||||
let l = if (n :> string) = "0" then l else (c "f", n) :: l in
|
||||
if (oc :> string) = "0" then (c "p", f) :: (c "n", s) :: l
|
||||
else (c "p", f) :: (c "n", s) :: (c "oc", oc) :: l
|
||||
| None -> (k, v) :: loop l
|
||||
in
|
||||
loop conf.env
|
||||
in
|
||||
let addr =
|
||||
let pref =
|
||||
let s = Util.get_request_string conf in
|
||||
match String.rindex_opt s '?' with
|
||||
| Some i -> String.sub s 0 i
|
||||
| None -> s
|
||||
in
|
||||
let pref =
|
||||
if pwd then pref
|
||||
else
|
||||
match String.rindex_opt pref '_' with
|
||||
| Some i -> String.sub pref 0 i
|
||||
| None -> pref
|
||||
in
|
||||
Util.get_server_string conf ^ pref
|
||||
in
|
||||
let suff : Adef.encoded_string =
|
||||
List.fold_right
|
||||
(fun (x, v) s ->
|
||||
if (v : Adef.encoded_string :> string) <> "" then
|
||||
x ^<^ "=" ^<^ v
|
||||
^^^ (if (s : Adef.encoded_string :> string) = "" then "" else "&")
|
||||
^<^ s
|
||||
else s)
|
||||
(("lang", Mutil.encode conf.lang) :: env)
|
||||
(Adef.encoded "")
|
||||
in
|
||||
if conf.cgi then addr ^<^ "?b=" ^<^ conf.bname ^<^ "&" ^<^ suff
|
||||
else addr ^<^ "?" ^<^ suff
|
||||
|
||||
let w_base =
|
||||
let none conf = Hutil.incorrect_request conf in
|
||||
Gwd_lib.Request.w_base ~none
|
||||
|
||||
let no_index conf base =
|
||||
let opt1 = Util.p_getenv conf.env "opt" = Some "no_index" in
|
||||
let opt2 = Util.p_getenv conf.env "opt" = Some "no_index_pwd" in
|
||||
if opt1 || opt2 then (
|
||||
let link = url_no_index conf base opt2 in
|
||||
Output.print_sstring conf {|<a href="http://|};
|
||||
Output.print_string conf link;
|
||||
Output.print_sstring conf {|">|};
|
||||
Output.print_string conf link;
|
||||
Output.print_sstring conf "</a>";
|
||||
Output.flush conf;
|
||||
exit 0)
|
||||
|
||||
let () = Gwd_lib.GwdPlugin.register_se ~ns @@ fun _assets -> w_base no_index
|
||||
9
plugins/xhtml/dune
Normal file
9
plugins/xhtml/dune
Normal file
@ -0,0 +1,9 @@
|
||||
(executable
|
||||
(name plugin_xhtml)
|
||||
(libraries geneweb geneweb.gwd_lib geneweb.wserver)
|
||||
(modes
|
||||
(native plugin)))
|
||||
|
||||
(alias
|
||||
(name plugin)
|
||||
(deps plugin_xhtml.cmxs))
|
||||
47
plugins/xhtml/plugin_xhtml.ml
Normal file
47
plugins/xhtml/plugin_xhtml.ml
Normal file
@ -0,0 +1,47 @@
|
||||
open Geneweb
|
||||
open Config
|
||||
|
||||
let ns = "xhtml"
|
||||
|
||||
let () =
|
||||
Gwd_lib.GwdPlugin.register_se ~ns @@ fun _assets conf _base ->
|
||||
if Util.p_getenv conf.env "xhtml" = Some "on" then
|
||||
let buffer_status = ref None in
|
||||
let buffer_headers = ref [] in
|
||||
let buffer_body = Buffer.create 1023 in
|
||||
let previous_status = conf.output_conf.status in
|
||||
let previous_header = conf.output_conf.header in
|
||||
let previous_body = conf.output_conf.body in
|
||||
let previous_flush = conf.output_conf.flush in
|
||||
let status s = buffer_status := Some s in
|
||||
let header s = buffer_headers := s :: !buffer_headers in
|
||||
let body s = Buffer.add_string buffer_body s in
|
||||
let flush () =
|
||||
conf.output_conf <-
|
||||
{
|
||||
status = previous_status;
|
||||
header = previous_header;
|
||||
body = previous_body;
|
||||
flush = previous_flush;
|
||||
};
|
||||
(match !buffer_status with Some s -> Output.status conf s | None -> ());
|
||||
List.iter
|
||||
(fun s ->
|
||||
Output.header conf "%s"
|
||||
@@
|
||||
try
|
||||
Scanf.sscanf s "Content-type: %_s; charset=%s" (fun c ->
|
||||
"Content-type: application/xhtml+xml; charset=" ^ c)
|
||||
with _ -> (
|
||||
try
|
||||
Scanf.sscanf s "Content-type: %_s"
|
||||
"Content-type: application/xhtml+xml"
|
||||
with _ -> s))
|
||||
(List.rev !buffer_headers);
|
||||
let open Markup in
|
||||
buffer buffer_body |> parse_html |> signals |> write_xml |> to_string
|
||||
|> Output.print_sstring conf;
|
||||
Output.flush conf;
|
||||
Buffer.reset buffer_body
|
||||
in
|
||||
conf.output_conf <- { status; header; body; flush }
|
||||
Reference in New Issue
Block a user