src/utils/lib/gettext.ml4

   1 (* Copyright 2001, 2002 b8_bavard, b8_fee_carabine, INRIA *)
   2 (*
   3     This file is part of mldonkey.
   4
   5     mldonkey is free software; you can redistribute it and/or modify
   6     it under the terms of the GNU General Public License as published by
   7     the Free Software Foundation; either version 2 of the License, or
   8     (at your option) any later version.
   9
  10     mldonkey is distributed in the hope that it will be useful,
  11     but WITHOUT ANY WARRANTY; without even the implied warranty of
  12     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13     GNU General Public License for more details.
  14
  15     You should have received a copy of the GNU General Public License
  16     along with mldonkey; if not, write to the Free Software
  17     Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  18 *)
  19
  20 open Printf2
  21 open Autoconf
  22
  23 let log_prefix = "[Gettext]"
  24
  25 let lprintf_nl fmt =
  26   lprintf_nl2 log_prefix fmt
  27
  28 let lprintf_n fmt =
  29   lprintf2 log_prefix fmt
  30
  31 type expected_types =
  32   Type_int
  33 | Type_char
  34 | Type_string
  35 | Type_float
  36 | Type_bool
  37 | Type_int32
  38 | Type_int64
  39 | Type_nativeint
  40
  41 let ty_arrow x y = x :: y
  42
  43 (* Taken from ocaml-3.04, typing/typecore.ml *)
  44
  45 let type_format fmt =
  46   let len = String.length fmt in
  47   let incomplete i =
  48     failwith (Printf.sprintf "Incomplete format %s" (String.sub fmt i (len - i)))
  49   in
  50   let bad_format i j=
  51     failwith (Printf.sprintf "Bad format %s" (String.sub fmt i (j - i + 1)))
  52
  53   in
  54   let ty_result = [] in
  55   let rec scan_format i =
  56     if i >= len then ty_result else
  57     match fmt.[i] with
  58     | '%' -> scan_flags i (i+1)
  59     | _ -> scan_format (i+1)
  60   and scan_flags i j =
  61     if j >= len then incomplete i else
  62     match fmt.[j] with
  63     | '#' | '0' | '-' | ' ' | '+' -> scan_flags i (j+1)
  64     | _ -> scan_width i j
  65   and scan_width i j =
  66     if j >= len then incomplete i else
  67     match fmt.[j] with
  68     | '*' -> ty_arrow Type_int (scan_dot i (j+1))
  69     | '.' -> scan_precision i (j+1)
  70     | _ -> scan_fixed_width i j
  71   and scan_fixed_width i j =
  72     if j >= len then incomplete i else
  73     match fmt.[j] with
  74     | '0' .. '9' | '-' | '+' -> scan_fixed_width i (j+1)
  75     | '.' -> scan_precision i (j+1)
  76     | _ -> scan_conversion i j
  77   and scan_dot i j =
  78     if j >= len then incomplete i else
  79     match fmt.[j] with
  80     | '.' -> scan_precision i (j+1)
  81     | _ -> scan_conversion i j
  82   and scan_precision i j =
  83     if j >= len then incomplete i else
  84     match fmt.[j] with
  85     | '*' -> ty_arrow Type_int (scan_conversion i (j+1))
  86     | _ -> scan_fixed_precision i j
  87   and scan_fixed_precision i j =
  88     if j >= len then incomplete i else
  89     match fmt.[j] with
  90     | '0' .. '9' | '-' | '+' -> scan_fixed_precision i (j+1)
  91     | _ -> scan_conversion i j
  92   and scan_conversion i j =
  93     if j >= len then incomplete i else
  94     match fmt.[j] with
  95     | '%' -> scan_format (j+1)
  96     | 's' | 'S' | '[' ->
  97         ty_arrow Type_string (scan_format (j+1))
  98     | 'c' | 'C' ->
  99         ty_arrow Type_char (scan_format (j+1))
 100     | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' | 'N' ->
 101         ty_arrow Type_int (scan_format (j+1))
 102     | 'f' | 'e' | 'E' | 'g' | 'G' ->
 103         ty_arrow Type_float (scan_format (j+1))
 104     | 'b' ->
 105         ty_arrow Type_bool (scan_format (j+1))
 106     | 'a' ->
 107         bad_format i j
 108     | 't' ->
 109         bad_format i j
 110     | 'l' ->
 111         if j+1 >= len then incomplete i else begin
 112             match fmt.[j+1] with
 113             | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' ->
 114                 ty_arrow Type_int32 (scan_format (j+2))
 115             | c ->
 116                 bad_format i j
 117           end
 118     | 'n' ->
 119         if j+1 >= len then incomplete i else begin
 120             match fmt.[j+1] with
 121             | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' ->
 122                 ty_arrow Type_nativeint (scan_format (j+2))
 123             | c ->
 124                 bad_format i j
 125         end
 126     | 'L' ->
 127         if j+1 >= len then incomplete i else begin
 128           match fmt.[j+1] with
 129           | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' ->
 130               ty_arrow Type_int64 (scan_format (j+2))
 131           | c ->
 132               bad_format i j
 133         end
 134     | c ->
 135         bad_format i j
 136   in
 137   scan_format 0
 138
 139 type 'a variable
 140 type 'a arrow
 141
 142
 143 let arrow_add_variable
 144   (x : 'a variable)
 145   (y : 'b arrow) =
 146   let x = Obj.magic x in
 147   let y = Obj.magic y in
 148   (Obj.magic (x :: y) : ('a -> 'b) arrow)
 149
 150
 151
 152 open Options
 153
 154 let value_to_text (expected_type : 'a arrow) v =
 155   let s = value_to_string v in
 156   let expected_type = Obj.magic expected_type in
 157   let format_type = type_format s in
 158   if format_type = expected_type then
 159     (Obj.magic s : ('a, unit, string) format) else
 160     failwith "Bad format"
 161
 162 let text_to_value v =
 163   let v = Obj.magic v in
 164   string_to_value v
 165
 166 let text_option (expected_type : 'a arrow)
 167   =
 168   define_option_class "Text"
 169     (value_to_text expected_type)
 170   text_to_value
 171
 172 let gettext v = Printf.sprintf !!v
 173
 174 let buftext buf (v : ('a, Buffer.t, unit) format Options.option_record) =
 175   Printf.bprintf buf !!v
 176
 177 module T = struct
 178     let int x = arrow_add_variable (Obj.magic Type_int : int variable) x
 179     let char x = arrow_add_variable (Obj.magic Type_char : char variable) x
 180     let string x = arrow_add_variable (Obj.magic Type_string : string variable) x
 181     let float x = arrow_add_variable (Obj.magic Type_float : float variable) x
 182     let bool x = arrow_add_variable (Obj.magic Type_bool : bool variable) x
 183     let int32 x = arrow_add_variable (Obj.magic Type_int32 : int32 variable) x
 184     let int64 x = arrow_add_variable (Obj.magic Type_int64 : int64 variable) x
 185     let nativeint x = arrow_add_variable (Obj.magic Type_nativeint : nativeint variable) x
 186     let format = (Obj.magic [] : string arrow)
 187     let bformat = (Obj.magic [] : unit arrow)
 188     let option = text_option
 189     let boption x = (Obj.magic text_option) x
 190   end
 191
 192
 193 (********* Some tests ************)
 194
 195 (*
 196 let option_file = create_options_file "test.ini"
 197
 198 let nshared = define_option option_file
 199   ["nshared"] "Text for Nshared option"
 200     (text_option
 201       (T.int (T.int32 T.format)))
 202   "Shared: %d/%ld"
 203
 204 let _ =
 205   try
 206     load option_file
 207   with Sys_error _ ->
 208       save_with_help option_file
 209
 210 let _ =
 211   lprint_string (Printf.sprintf !! nshared 23 (Int32.one));
 212   *)
 213
 214 type 'a _string = {
 215     name : string;
 216     index : int;
 217   }
 218
 219 let strings = Hashtbl.create 1111
 220 let next_slot = ref 0
 221 let translation = ref [||]
 222 let verified = ref [||]
 223 let default = ref [||]
 224 let requests = ref [||]
 225 let strings_file = ref None
 226
 227 let strings_file_error = ref false
 228 let save_strings_file = ref false
 229
 230 let no_translation = "   "
 231 let modules = Hashtbl.create 11
 232
 233 let register modname x =
 234   try
 235     Hashtbl.find strings x
 236   with Not_found ->
 237
 238 (*          lprintf "New message [%s]\n" x;  *)
 239       save_strings_file := true;
 240
 241       if !next_slot = Array.length !translation then begin
 242
 243 (*              lprintf "Incrementing size\n"; *)
 244           let new_array = Array.make (2 * !next_slot+ 1) false
 245           in
 246           Array.blit !verified 0 new_array 0 !next_slot;
 247           verified := new_array;
 248
 249           let new_array = Array.make (2 * !next_slot+ 1) no_translation
 250           in
 251           Array.blit !translation 0 new_array 0 !next_slot;
 252           translation := new_array;
 253
 254           let new_array = Array.make (2 * !next_slot+ 1) 0
 255           in
 256           Array.blit !requests 0 new_array 0 !next_slot;
 257           requests := new_array;
 258
 259           let new_array = Array.make (2 * !next_slot+ 1) no_translation
 260           in
 261           Array.blit !default 0 new_array 0 !next_slot;
 262           default := new_array;
 263
 264         end;
 265       let index = !next_slot in
 266       let m = { name = x ; index = index } in
 267       ( try
 268           let names = Hashtbl.find modules modname in
 269           names := index :: !names
 270         with _ ->
 271             Hashtbl.add modules modname (ref [index]));
 272       Hashtbl.add strings x m;
 273       incr next_slot;
 274       !default.(index ) <- x;
 275       m
 276
 277 let translate modname s t =
 278   if t <> "" && t <> s then
 279     begin
 280 (*          lprintf "Register\n"; *)
 281       let m = register modname s in
 282 (*          lprintf "Translation: %s = %s\n" s t; *)
 283       save_strings_file := true;
 284       !translation.(m.index) <- t
 285     end
 286 (*
 287     let  x =
 288       let y = (Obj.magic x : string) in
 289       Obj.magic (register y : string message)
 290
 291     let s_ x = register x
 292 *)
 293
 294
 295 let verify index translated =
 296   let index_type = type_format !default.(index) in
 297   let translated_type = type_format translated in
 298   if index_type = translated_type then begin
 299       !verified.(index) <- true;
 300       true
 301     end else begin
 302       lprintf_nl "Bad format for %s\n" translated;
 303       save_strings_file := true;
 304       !translation.(index) <- no_translation;
 305       false
 306     end
 307
 308 let ss_ modname (x : string) = register modname x
 309 let _ss m =
 310   let index = m.index in
 311   !requests.(index) <- !requests.(index) + 1;
 312   let translation = !translation.(index) in
 313   let s= if translation == no_translation then
 314       !default.(index)
 315     else
 316       translation
 317   in
 318   s
 319
 320 let _s modname (x : string) = _ss (ss_ modname x)
 321
 322 let bb_ : string -> ('a, 'b, 'c, 'd) format4 -> ('a, 'b, 'c, 'd) format4 _string = fun modname -> Obj.magic (ss_ modname)
 323 let _bb : ('a, 'b, 'c, 'd) format4 _string -> ('a, 'b, 'c, 'd) format4 = fun m ->
 324   let index = m.index in
 325   !requests.(index) <- !requests.(index) + 1;
 326   let translation = !translation.(index) in
 327   let s= if translation == no_translation then
 328       !default.(index)
 329     else
 330     if !verified.(index) || verify index translation then
 331       translation
 332     else !default.(index)
 333   in
 334   Obj.magic s
 335
 336 let _b modname x = _bb (bb_ modname x)
 337
 338
 339 let save_strings () =
 340   match !strings_file with
 341     None -> ()
 342   | Some filename ->
 343       if !save_strings_file && not !strings_file_error then
 344         try
 345           Unix2.tryopen_write filename (fun oc ->
 346
 347             Hashtbl.iter (fun modname names ->
 348
 349                 Printf.fprintf oc "(************************************)\n";
 350                 Printf.fprintf oc "         module \"%s\"\n" (String.escaped modname);
 351                 Printf.fprintf oc "(************************************)\n\n";
 352
 353
 354                 List.iter (fun i ->
 355
 356                     Printf.fprintf oc "\"%s\" = \"%s\"\n\n"
 357                       (String.escaped !default.(i))
 358                     (String.escaped
 359                         (if !translation.(i) != no_translation then
 360                           !translation.(i)
 361                         else
 362                           !default.(i)))
 363
 364                 ) !names;
 365
 366             ) modules;
 367
 368             save_strings_file := false)
 369         with e ->
 370             lprintf_nl "save_strings: Error %s"
 371               (Printexc2.to_string e)
 372 open Genlex2
 373
 374 let lexer = make_lexer [ "=" ; "module" ]
 375
 376 let current_modname = ref ""
 377
 378 let rec parse_file = (parser
 379   |   [< 'String s0; 'Kwd "="; 'String s1; strm >] ->
 380 (*      lprintf "trans\n"; *)
 381   translate !current_modname s0 s1; parse_file strm
 382   |   [< 'Kwd "module"; 'String modname; strm >] ->
 383   current_modname := modname;
 384   parse_file  strm
 385   |   [< >] -> (* lprintf "done\n" *) ())
 386
 387 let set_strings_file filename =
 388   let filename =
 389     let extension = try
 390         Unix.getenv "LANG"
 391       with _ -> (Charset.Locale.default_language ^ "_" ^ Charset.Locale.locale_string)
 392     in
 393     Printf.sprintf "%s.%s" filename extension
 394   in
 395
 396   (match !strings_file with Some _ -> ()
 397     | None ->
 398         Pervasives.at_exit (fun _ -> try save_strings () with _ -> ()));
 399   strings_file := Some filename;
 400
 401 (* If the file exists, load it. Check that '%' formats are the same
 402 in the default and in the translation. *)
 403 (*lprintf "Loading...\n"; *)
 404   (try
 405     Unix2.tryopen_read filename (fun ic ->
 406       lprintf_nl "Loading language resource %s" filename;
 407       let s = Stream.of_channel ic in
 408       try
 409         let stream = lexer s in
 410 (*        lprintf "x\n"; *)
 411         current_modname := "general";
 412         parse_file stream
 413       with e ->
 414           strings_file_error := true;
 415         lprintf_nl "set_strings_file: Exception %s in %s at pos %d"
 416           (Printexc2.to_string e) filename (Stream.count s))
 417     with e ->
 418         save_strings_file := true);
 419   save_strings ()
 420
 421
 422 let _ =
 423   try
 424     let file = Sys.getenv "GETTEXT_FILE" in
 425     let ext = Sys.getenv "LANG" in
 426     let f1 = Printf.sprintf "%s.en" file in
 427     let f2 = Printf.sprintf "%s.%s" file ext in
 428     let strings = Hashtbl.create 111 in
 429
 430 let translate1 s0 s1 =
 431   lprintf_nl "translate0 %s" s0;
 432   Hashtbl.add strings s0 s1
 433 in
 434
 435
 436 let rec parse_file = (parser
 437   |   [< 'Ident s0; 'Kwd "="; s1 = parse_next; strm >] ->
 438   translate1 s0 s1; parse_file strm
 439   |   [< >] -> (* lprintf "done\n" *) ())
 440
 441 and parse_next = parser
 442       |   [< 'Ident s1 >] -> s1
 443       |   [< 'String s1 >] -> s1
 444 in
 445
 446 (try
 447   Unix2.tryopen_read f1(fun ic ->
 448     let s = Stream.of_channel ic in
 449     try
 450       let stream = lexer s in
 451 (*        lprintf "x\n"; *)
 452       parse_file stream
 453     with e ->
 454         strings_file_error := true;
 455         lprintf_nl "set_strings_file: Exception %s in %s at pos %d"
 456            (Printexc2.to_string e) f1 (Stream.count s))
 457   with e ->
 458     save_strings_file := true;
 459     lprintf_nl "set_strings_file: no message file found. Creating one");
 460
 461 let translate2 s0 s1 =
 462   try
 463     lprintf_nl "translate2 %s" s0;
 464     let s0 = Hashtbl.find strings s0 in
 465     translate "Former Translation" s0 s1
 466   with _ -> lprintf_nl "No translation for %s" s0
 467 in
 468
 469 let rec parse_file = (parser
 470   |   [< 'Ident s0; 'Kwd "="; s1 = parse_next; strm >] ->
 471   translate2 s0 s1; parse_file strm
 472   |   [< >] -> (* lprintf "done\n" *) ())
 473
 474 and parse_next = parser
 475       |   [< 'Ident s1 >] -> s1
 476       |   [< 'String s1 >] -> s1
 477 in
 478
 479       try
 480         Unix2.tryopen_read f2 (fun ic ->
 481        let s = Stream.of_channel ic in
 482         try
 483           let stream = lexer s in
 484 (*        lprintf "x\n"; *)
 485           parse_file stream
 486         with e ->
 487             strings_file_error := true;
 488             lprintf_nl "set_strings_file: Exception %s in %s at pos %d"
 489                (Printexc2.to_string e) f2 (Stream.count s))
 490      with e ->
 491        save_strings_file := true;
 492        lprintf_nl "set_strings_file: no message file found. Creating one"
 493
 494
 495   with _ -> ()
 496