(**************************************************************************)
(* ocaml-gettext: a library to translate messages *)
(* *)
(* Copyright (C) 2003-2008 Sylvain Le Gall <sylvain@le-gall.net> *)
(* *)
(* This library is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Lesser General Public *)
(* License as published by the Free Software Foundation; either *)
(* version 2.1 of the License, or (at your option) any later version; *)
(* with the OCaml static compilation exception. *)
(* *)
(* This library is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *)
(* Lesser General Public License for more details. *)
(* *)
(* You should have received a copy of the GNU Lesser General Public *)
(* License along with this library; if not, write to the Free Software *)
(* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 *)
(* USA *)
(**************************************************************************)
open GettextTypes;;
open GettextCompat;;
open GettextUtils;;
open GettextModules;;
open Lexing;;
(* Function the main global variable of gettext with/without thread *)
type global_type =
{
t : t option;
realize : t -> t';
t' : t' option;
}
;;
(* Default value *)
let dummy_realize =
(fun t printf_format textdomain str str_plural category -> str)
;;
let default_realize =
dummy_realize
;;
(* Referenced function used to manage access to global variable,
in other word to be fullfiled with mutex locking/unlocking if
needed
*)
let global_lock = ref ( fun () -> () )
;;
let global_unlock = ref ( fun () -> () )
;;
let global = ref {
t = None;
realize = default_realize;
t' = None;
}
;;
let get_global_t () =
let t =
!global_lock ();
!global.t
in
!global_unlock ();
match t with
Some t -> t
| None -> raise GettextUninitialized
;;
let set_global_t t =
let () =
!global_lock ();
global := {
!global with
t = Some t;
t' = None;
}
in
!global_unlock ()
;;
let set_global_realize realize =
let () =
!global_lock ();
global := {
!global with
realize = realize;
t' = None
}
in
!global_unlock ()
;;
let get_global_t' () =
let t' =
!global_lock ();
match !global.t' with
None ->
(* Try to build it out of the other value provided *)
let t =
match !global.t with
Some t -> t
| None -> raise GettextUninitialized
in
let t' =
!global.realize t
in
global := {
!global with
t' = Some t'
};
t'
| Some t' ->
t'
in
!global_unlock ();
t'
;;
(* High level functions *)
module Library =
functor (Init : INIT_TYPE) ->
struct
let init = (Init.textdomain, Init.codeset, Init.dir) :: Init.dependencies
let s_ str = dgettext (get_global_t' ()) Init.textdomain str
let f_ str = fdgettext (get_global_t' ()) Init.textdomain str
let sn_ str = dngettext (get_global_t' ()) Init.textdomain str
let fn_ str = fdngettext (get_global_t' ()) Init.textdomain str
end
;;
(* i18n/l10n of gettext it self *)
module GettextGettext = Library(struct
let textdomain = "ocaml-gettext"
let codeset = None
let dir = None
let dependencies = []
(* Off course, we don't depend on anything because
we are the root of translation *)
end)
;;
(* Initialization of gettext library *)
let init = GettextGettext.init
;;
(* Exception *)
let string_of_exception exc =
(* It is important to keep the name f_ and s_, in order to allow ocaml-gettext
program to extract the string *)
let f_ x =
GettextGettext.f_ x
in
let s_ x =
GettextGettext.s_ x
in
let spf x =
Printf.sprintf x
in
let string_of_pos lexbuf =
let char_pos = lexbuf.lex_curr_p.pos_cnum - lexbuf.lex_curr_p.pos_bol
in
let line_pos = lexbuf.lex_curr_p.pos_lnum
in
spf (f_ "line %d character %d")
line_pos char_pos
in
match exc with
CompileProblemReadingFile(fln,error) ->
spf (f_ "Problem reading file %s: %s.") fln error
| CompileExtractionFailed(fln,cmd,status) ->
spf (f_ "Problem while extracting %s: command %S exits with code %d.")
fln cmd status
| CompileExtractionInterrupted(fln,cmd,signal) ->
spf (f_ "Problem while extracting %s: command %S killed by signal %d.")
fln cmd signal
| DomainFileDoesntExist(lst) ->
spf (f_ "Cannot find an approriate ocaml-gettext compiled file ( %s ).")
(string_of_list lst)
| GettextUninitialized ->
(s_ "Ocaml-gettext library is not initialized")
| MoInvalidOptions (lexbuf,text) ->
spf (f_ "Error while processing parsing of options at %s: %S.")
(string_of_pos lexbuf)
text
| MoInvalidPlurals (lexbuf,text) ->
spf (f_ "Error while processing parsing of plural at %s: %S.")
(string_of_pos lexbuf)
text
| MoInvalidContentType (lexbuf,text) ->
spf (f_ "Error while processing parsing of content-type at %s: %S.")
(string_of_pos lexbuf)
text
| MoInvalidFile ->
(s_ "MO file provided is not encoded following ocaml-gettext convention.")
| MoInvalidTranslationSingular (str,x) ->
spf (f_ "Trying to fetch the plural form %d of a singular form %S.")
x str
| MoInvalidTranslationPlural (lst,x) ->
spf (f_ "Trying to fetch the plural form %d of plural form %s.")
x (string_of_list lst)
| MoJunk (id,lst) ->
spf (f_ "Junk at the end of the plural form id %S: %s.")
id (string_of_list lst)
| MoEmptyEntry ->
(s_ "An empty entry has been encounter.")
| MoInvalidHeaderNegativeStrings ->
(s_ "Number of strings is negative.")
| MoInvalidHeaderTableStringOutOfBound((b1,e1),(b2,e2)) ->
spf (f_ "Offset of string table is out of bound ([%ld,%ld] should be in [%ld,%ld]).")
b1 e1 b2 e2
| MoInvalidHeaderTableTranslationOutOfBound((b1,e1),(b2,e2)) ->
spf (f_ "Offset of translation table is out of bound ([%ld,%ld] should be in [%ld,%ld]).")
b1 e1 b2 e2
| MoInvalidHeaderTableTranslationStringOverlap((b1,e1),(b2,e2)) ->
spf (f_ "Translation table and string table overlap ([%ld,%ld] and [%ld,%ld] have a non empty intersection).")
b1 e1 b2 e2
| MoInvalidStringOutOfBound(max,cur) ->
spf (f_ "Out of bound access when trying to find a string (%d < %d).")
max cur
| MoInvalidTranslationOutOfBound(max,cur) ->
spf (f_ "Out of bound access when trying to find a translation (%d < %d).")
max cur
| MoCannotOpenFile fln ->
spf (f_ "Could not open file %s.")
fln
| PoInvalidFile (s,lexbuf,chn) ->
spf (f_ "Error while processing parsing of PO file: %S at %s.")
s (string_of_pos lexbuf)
| PoFileInvalidIndex (id,i) ->
spf (f_ "Error while processing parsing of PO file, in msgid %S, %d index is out of bound.")
id i
| PoFileDoesntExist fl ->
spf (f_ "Error while trying to load PO file %s, file doesn't exist.")
fl
| PoInconsistentMerge (str1,str2) ->
spf (f_ "Error while merging two PO files: %S and %S cannot be merged.")
str1 str2
| TranslateStringNotFound str ->
spf (f_ "Cannot find string %S.")
str
| LocalePosixUnparseable str ->
spf (f_ "Unable to parse the POSIX language environment variable %s")
str
| _ ->
Printexc.to_string exc
;;
module Program =
functor (Init : INIT_TYPE) ->
functor (Realize : REALIZE_TYPE) ->
struct
let textdomain = Init.textdomain
let dependencies = (Init.textdomain, Init.codeset, Init.dir) :: Init.dependencies
let init =
(* Initialization from all the known textdomain/codeset/dir provided
by library linked with the program *)
(* It is important to keep f_ and s_, for the same reason as in
string_of_exception *)
let f_ x =
GettextGettext.f_ x
in
let s_ x =
GettextGettext.s_ x
in
let spf x =
Printf.sprintf x
in
let () =
set_global_t (GettextModules.create textdomain)
in
let () =
set_global_t (
List.fold_left (
fun t (textdomain,codeset_opt,dir_opt) ->
upgrade_textdomain t textdomain (codeset_opt,dir_opt)
) (get_global_t ()) dependencies
)
in
let () =
set_global_realize (Realize.realize)
in
[
"--gettext-failsafe",
(Arg.Symbol
(["ignore"; "inform-stderr"; "raise-exception"],
(fun x ->
match x with
| "ignore" ->
set_global_t
{(get_global_t ()) with
failsafe = Ignore}
| "inform-stderr" ->
set_global_t
{(get_global_t ()) with
failsafe = InformStderr string_of_exception}
| "raise-exception" ->
set_global_t {(get_global_t ()) with
failsafe = RaiseException}
| _ ->
()))),
spf
(f_ " Choose how to handle failure in ocaml-gettext. Default: %s.")
(match (get_global_t ()).failsafe with
| Ignore -> "ignore"
| InformStderr _ -> "inform-stderr"
| RaiseException -> "raise-exception");
"--gettext-disable",
(Arg.Unit (fun () -> set_global_realize dummy_realize)),
s_ " Disable the translation perform by ocaml-gettext. \
Default: enable.";
"--gettext-domain-dir",
(let current_textdomain =
ref textdomain
in
Arg.Tuple
[
Arg.String (fun textdomain ->
current_textdomain := textdomain);
Arg.String (fun dir ->
set_global_t
(bindtextdomain
!current_textdomain
dir
(get_global_t ())));
]),
spf
(f_ "textdomain dir Set a dir to search ocaml-gettext files \
for the specified domain. Default: %s.")
(string_of_list
(MapTextdomain.fold
(fun textdomain (_,dir_opt) lst ->
match dir_opt with
| Some dir -> (spf ("%s: %s") textdomain dir) :: lst
| None -> lst)
(get_global_t ()).textdomains []));
"--gettext-dir",
(Arg.String
(fun s -> set_global_t
{(get_global_t ()) with
path = s :: (get_global_t ()).path})),
spf
(f_ "dir Add a search dir for ocaml-gettext files. Default: %s.")
(string_of_list (get_global_t ()).path);
"--gettext-language",
(Arg.String (fun s ->
set_global_t
{(get_global_t ()) with
language = Some s})),
spf
(f_ "language Set the default language for ocaml-gettext. \
Default: %s.")
(match (get_global_t ()).language with
| Some s -> s
| None -> "(none)");
"--gettext-codeset",
(Arg.String (fun s -> set_global_t
{(get_global_t ()) with codeset = s})),
spf (f_ "codeset Set the default codeset for outputting string with \
ocaml-gettext. Default: %s.")
(get_global_t ()).codeset;
],
GettextConfig.copyright
let s_ str = dgettext (get_global_t' ()) textdomain str
let f_ str = fdgettext (get_global_t' ()) textdomain str
let sn_ str = dngettext (get_global_t' ()) textdomain str
let fn_ str = fdngettext (get_global_t' ()) textdomain str
end
;;