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 _string = {
 140     name : string;
 141     index : int;
 142   }
 143
 144 let strings = Hashtbl.create 1111
 145 let next_slot = ref 0
 146 let translation = ref [||]
 147 let verified = ref [||]
 148 let default = ref [||]
 149 let requests = ref [||]
 150 let strings_file = ref None
 151
 152 let strings_file_error = ref false
 153 let save_strings_file = ref false
 154
 155 let no_translation = "   "
 156 let modules = Hashtbl.create 11
 157
 158 let register modname x =
 159   try
 160     Hashtbl.find strings x
 161   with Not_found ->
 162
 163 (*          lprintf "New message [%s]\n" x;  *)
 164       save_strings_file := true;
 165
 166       if !next_slot = Array.length !translation then begin
 167
 168 (*              lprintf "Incrementing size\n"; *)
 169           let new_array = Array.create (2 * !next_slot+ 1) false
 170           in
 171           Array.blit !verified 0 new_array 0 !next_slot;
 172           verified := new_array;
 173
 174           let new_array = Array.create (2 * !next_slot+ 1) no_translation
 175           in
 176           Array.blit !translation 0 new_array 0 !next_slot;
 177           translation := new_array;
 178
 179           let new_array = Array.create (2 * !next_slot+ 1) 0
 180           in
 181           Array.blit !requests 0 new_array 0 !next_slot;
 182           requests := new_array;
 183
 184           let new_array = Array.create (2 * !next_slot+ 1) no_translation
 185           in
 186           Array.blit !default 0 new_array 0 !next_slot;
 187           default := new_array;
 188
 189         end;
 190       let index = !next_slot in
 191       let m = { name = x ; index = index } in
 192       ( try
 193           let names = Hashtbl.find modules modname in
 194           names := index :: !names
 195         with _ ->
 196             Hashtbl.add modules modname (ref [index]));
 197       Hashtbl.add strings x m;
 198       incr next_slot;
 199       !default.(index ) <- x;
 200       m
 201
 202 let translate modname s t =
 203   if t <> "" && t <> s then
 204     begin
 205 (*          lprintf "Register\n"; *)
 206       let m = register modname s in
 207 (*          lprintf "Translation: %s = %s\n" s t; *)
 208       save_strings_file := true;
 209       !translation.(m.index) <- t
 210     end
 211
 212 let verify index translated =
 213   let index_type = type_format !default.(index) in
 214   let translated_type = type_format translated in
 215   if index_type = translated_type then begin
 216       !verified.(index) <- true;
 217       true
 218     end else begin
 219       lprintf_nl "Bad format for %s\n" translated;
 220       save_strings_file := true;
 221       !translation.(index) <- no_translation;
 222       false
 223     end
 224
 225 let ss_ : string -> string -> string _string = register
 226 let _ss : string _string -> string = fun m ->
 227   let index = m.index in
 228   !requests.(index) <- !requests.(index) + 1;
 229   let translation = !translation.(index) in
 230   let s= if translation == no_translation then
 231       !default.(index)
 232     else
 233       translation
 234   in
 235   s
 236
 237 let _s modname (x : string) = _ss (ss_ modname x)
 238
 239 let bb_ : string -> ('a, 'b, 'c, 'd) format4 -> ('a, 'b, 'c, 'd) format4 _string = fun modname -> Obj.magic (ss_ modname)
 240 let _bb : ('a, 'b, 'c, 'd) format4 _string -> ('a, 'b, 'c, 'd) format4 = fun m ->
 241   let index = m.index in
 242   !requests.(index) <- !requests.(index) + 1;
 243   let translation = !translation.(index) in
 244   let s= if translation == no_translation then
 245       !default.(index)
 246     else
 247     if !verified.(index) || verify index translation then
 248       translation
 249     else !default.(index)
 250   in
 251   Obj.magic s
 252
 253 let _b modname x = _bb (bb_ modname x)
 254
 255 let save_strings () =
 256   match !strings_file with
 257     None -> ()
 258   | Some filename ->
 259       if !save_strings_file && not !strings_file_error then
 260         try
 261           Unix2.tryopen_write filename (fun oc ->
 262
 263             Hashtbl.iter (fun modname names ->
 264
 265                 Printf.fprintf oc "(************************************)\n";
 266                 Printf.fprintf oc "         module \"%s\"\n" (String.escaped modname);
 267                 Printf.fprintf oc "(************************************)\n\n";
 268
 269
 270                 List.iter (fun i ->
 271
 272                     Printf.fprintf oc "\"%s\" = \"%s\"\n\n"
 273                       (String.escaped !default.(i))
 274                     (String.escaped
 275                         (if !translation.(i) != no_translation then
 276                           !translation.(i)
 277                         else
 278                           !default.(i)))
 279
 280                 ) !names;
 281
 282             ) modules;
 283
 284             save_strings_file := false)
 285         with e ->
 286             lprintf_nl "save_strings: Error %s"
 287               (Printexc2.to_string e)
 288 open Genlex2
 289
 290 let lexer = make_lexer [ "=" ; "module" ]
 291
 292 let current_modname = ref ""
 293
 294 let rec parse_file = (parser
 295   |   [< 'String s0; 'Kwd "="; 'String s1; strm >] ->
 296 (*      lprintf "trans\n"; *)
 297   translate !current_modname s0 s1; parse_file strm
 298   |   [< 'Kwd "module"; 'String modname; strm >] ->
 299   current_modname := modname;
 300   parse_file  strm
 301   |   [< >] -> (* lprintf "done\n" *) ())
 302
 303 let set_strings_file filename =
 304   let filename =
 305     let extension = try
 306         Unix.getenv "LANG"
 307       with _ -> (Charset.Locale.default_language ^ "_" ^ Charset.Locale.locale_string)
 308     in
 309     Printf.sprintf "%s.%s" filename extension
 310   in
 311
 312   (match !strings_file with Some _ -> ()
 313     | None ->
 314         Pervasives.at_exit (fun _ -> try save_strings () with _ -> ()));
 315   strings_file := Some filename;
 316
 317 (* If the file exists, load it. Check that '%' formats are the same
 318 in the default and in the translation. *)
 319 (*lprintf "Loading...\n"; *)
 320   (try
 321     Unix2.tryopen_read filename (fun ic ->
 322       lprintf_nl "Loading language resource %s" filename;
 323       let s = Stream.of_channel ic in
 324       try
 325         let stream = lexer s in
 326 (*        lprintf "x\n"; *)
 327         current_modname := "general";
 328         parse_file stream
 329       with e ->
 330           strings_file_error := true;
 331         lprintf_nl "set_strings_file: Exception %s in %s at pos %d"
 332           (Printexc2.to_string e) filename (Stream.count s))
 333     with e ->
 334         save_strings_file := true);
 335   save_strings ()
 336
 337
 338 let _ =
 339   try
 340     let file = Sys.getenv "GETTEXT_FILE" in
 341     let ext = Sys.getenv "LANG" in
 342     let f1 = Printf.sprintf "%s.en" file in
 343     let f2 = Printf.sprintf "%s.%s" file ext in
 344     let strings = Hashtbl.create 111 in
 345
 346 let translate1 s0 s1 =
 347   lprintf_nl "translate0 %s" s0;
 348   Hashtbl.add strings s0 s1
 349 in
 350
 351
 352 let rec parse_file = (parser
 353   |   [< 'Ident s0; 'Kwd "="; s1 = parse_next; strm >] ->
 354   translate1 s0 s1; parse_file strm
 355   |   [< >] -> (* lprintf "done\n" *) ())
 356
 357 and parse_next = parser
 358       |   [< 'Ident s1 >] -> s1
 359       |   [< 'String s1 >] -> s1
 360 in
 361
 362 (try
 363   Unix2.tryopen_read f1(fun ic ->
 364     let s = Stream.of_channel ic in
 365     try
 366       let stream = lexer s in
 367 (*        lprintf "x\n"; *)
 368       parse_file stream
 369     with e ->
 370         strings_file_error := true;
 371         lprintf_nl "set_strings_file: Exception %s in %s at pos %d"
 372            (Printexc2.to_string e) f1 (Stream.count s))
 373   with e ->
 374     save_strings_file := true;
 375     lprintf_nl "set_strings_file: no message file found. Creating one");
 376
 377 let translate2 s0 s1 =
 378   try
 379     lprintf_nl "translate2 %s" s0;
 380     let s0 = Hashtbl.find strings s0 in
 381     translate "Former Translation" s0 s1
 382   with _ -> lprintf_nl "No translation for %s" s0
 383 in
 384
 385 let rec parse_file = (parser
 386   |   [< 'Ident s0; 'Kwd "="; s1 = parse_next; strm >] ->
 387   translate2 s0 s1; parse_file strm
 388   |   [< >] -> (* lprintf "done\n" *) ())
 389
 390 and parse_next = parser
 391       |   [< 'Ident s1 >] -> s1
 392       |   [< 'String s1 >] -> s1
 393 in
 394
 395       try
 396         Unix2.tryopen_read f2 (fun ic ->
 397        let s = Stream.of_channel ic in
 398         try
 399           let stream = lexer s in
 400 (*        lprintf "x\n"; *)
 401           parse_file stream
 402         with e ->
 403             strings_file_error := true;
 404             lprintf_nl "set_strings_file: Exception %s in %s at pos %d"
 405                (Printexc2.to_string e) f2 (Stream.count s))
 406      with e ->
 407        save_strings_file := true;
 408        lprintf_nl "set_strings_file: no message file found. Creating one"
 409
 410
 411   with _ -> ()
 412