From fac62aeab4fec0a0760b3dbc4200d20a3c0181a6 Mon Sep 17 00:00:00 2001
From: spiralvoice <spiralvoice>
Date: Sun, 23 Feb 2014 18:16:11 +0000
Subject: [PATCH] patch #8329

---
 distrib/ChangeLog                |   1 +
 src/daemon/common/commonFile.mli |   2 +-
 src/utils/cdk/printf2.ml         | 196 +++------------------------------------
 src/utils/cdk/printf2.mli        |  24 ++---
 src/utils/lib/gettext.ml4        |   4 +-
 src/utils/lib/gettext.mli        |   2 +-
 6 files changed, 26 insertions(+), 203 deletions(-)

diff --git a/distrib/ChangeLog b/distrib/ChangeLog
index 85d4d644..09605e99 100644
--- a/distrib/ChangeLog
+++ b/distrib/ChangeLog
@@ -15,6 +15,7 @@ ChangeLog
 =========
 
 2014/02/23:
+8329: printf2: reduce complexity, use Printf.ksprintf (ygrek)
 8328: gettext: reduce complexity, drop unused code (ygrek)
 8327: GTK2 GUI: fix wrong url on splash screen (ygrek)
 8326: BT: disable announcing to 127.0.0.1 (ygrek)
diff --git a/src/daemon/common/commonFile.mli b/src/daemon/common/commonFile.mli
index 875f5e83..b2320702 100644
--- a/src/daemon/common/commonFile.mli
+++ b/src/daemon/common/commonFile.mli
@@ -155,7 +155,7 @@ val set_file_owner : CommonTypes.file -> CommonTypes.userdb -> unit
 val file_owner : CommonTypes.file -> CommonTypes.userdb
 val set_file_group : CommonTypes.file -> CommonTypes.groupdb option -> unit
 val file_group : CommonTypes.file -> CommonTypes.groupdb option
-val lprintf_file_nl : CommonTypes.file -> ('a, unit, unit) Pervasives.format -> 'a
+val lprintf_file_nl : CommonTypes.file -> ('a, unit, string, unit) Pervasives.format4 -> 'a
 
 (** [concat_file dir filename] sanitizes [filename] and appends it to [dir] *)
 val concat_file : string -> string -> string
diff --git a/src/utils/cdk/printf2.ml b/src/utils/cdk/printf2.ml
index 4bdfc828..b3b9a070 100644
--- a/src/utils/cdk/printf2.ml
+++ b/src/utils/cdk/printf2.ml
@@ -23,195 +23,21 @@ open Syslog
 
 let syslog_oc = ref None
 
-external format_int: string -> int -> string = "caml_format_int"
-external format_int32: string -> int32 -> string = "caml_int32_format"
-external format_nativeint: string -> nativeint -> string = "caml_nativeint_format"
-external format_int64: string -> int64 -> string = "caml_int64_format"
-external format_float: string -> float -> string = "caml_format_float"
-
 let log_time () =
-let t = Unix.localtime (Unix.time ()) in
+  let t = Unix.localtime (Unix.time ()) in
   let { Unix.tm_year = tm_year; Unix.tm_mon = tm_mon; Unix.tm_mday = tm_mday;
-        Unix.tm_hour = tm_hour; Unix.tm_min = tm_min; Unix.tm_sec = tm_sec } = t in
-    Printf.sprintf "%4d/%02d/%02d %02d:%02d:%02d " (tm_year+1900) (tm_mon+1) tm_mday tm_hour tm_min tm_sec
-
-let bad_format fmt pos =
-  invalid_arg
-    ("printf: bad format " ^ String.sub fmt pos (String.length fmt - pos))
-
-(* Format a string given a %s format, e.g. %40s or %-20s.
-   To do: ignore other flags (#, +, etc)? *)
-
-let format_string format s =
-  let rec parse_format neg i =
-    if i >= String.length format then (0, neg) else
-    match String.unsafe_get format i with
-    | '1'..'9' ->
-        (int_of_string (String.sub format i (String.length format - i - 1)),
-         neg)
-    | '-' ->
-        parse_format true (succ i)
-    | _ ->
-        parse_format neg (succ i) in
-  let (p, neg) =
-    try parse_format false 1 with Failure _ -> bad_format format 0 in
-  if String.length s < p then begin
-    let res = String.make p ' ' in
-    if neg
-    then String.blit s 0 res 0 (String.length s)
-    else String.blit s 0 res (p - String.length s) (String.length s);
-    res
-  end else
-    s
-
-(* Extract a %format from [fmt] between [start] and [stop] inclusive.
-   '*' in the format are replaced by integers taken from the [widths] list.
-   The function is somewhat optimized for the "no *" case. *)
-
-let extract_format fmt start stop widths =
-  match widths with
-  | [] -> String.sub fmt start (stop - start + 1)
-  | _  ->
-      let b = Buffer.create (stop - start + 10) in
-      let rec fill_format i w =
-        if i > stop then Buffer.contents b else
-          match (String.unsafe_get fmt i, w) with
-            ('*', h::t) ->
-              Buffer.add_string b (string_of_int h); fill_format (succ i) t
-          | ('*', []) ->
-              bad_format fmt start (* should not happen *)
-          | (c, _) ->
-              Buffer.add_char b c; fill_format (succ i) w
-      in fill_format start (List.rev widths)
-
-(* Decode a %format and act on it.
-   [fmt] is the printf format style, and [pos] points to a [%] character.
-   After consuming the appropriate number of arguments and formatting
-   them, one of the three continuations is called:
-   [cont_s] for outputting a string (args: string, next pos)
-   [cont_a] for performing a %a action (args: fn, arg, next pos)
-   [cont_t] for performing a %t action (args: fn, next pos)
-   "next pos" is the position in [fmt] of the first character following
-   the %format in [fmt]. *)
-
-(* Note: here, rather than test explicitly against [String.length fmt]
-   to detect the end of the format, we use [String.unsafe_get] and
-   rely on the fact that we'll get a "nul" character if we access
-   one past the end of the string.  These "nul" characters are then
-   caught by the [_ -> bad_format] clauses below.
-   Don't do this at home, kids. *)
-
-let scan_format fmt pos cont_s cont_a cont_t =
-  let rec scan_flags widths i =
-    match String.unsafe_get fmt i with
-    | '*' ->
-        Obj.magic(fun w -> scan_flags (w :: widths) (succ i))
-    | '0'..'9' | '.' | '#' | '-' | ' ' | '+' -> scan_flags widths (succ i)
-    | _ -> scan_conv widths i
-  and scan_conv widths i =
-    match String.unsafe_get fmt i with
-    | '%' ->
-        cont_s "%" (succ i)
-    | 's' | 'S' as conv ->
-        Obj.magic (fun (s: string) ->
-          let s = if conv = 's' then s else "\"" ^ String.escaped s ^ "\"" in
-          if i = succ pos (* optimize for common case %s *)
-          then cont_s s (succ i)
-          else cont_s (format_string (extract_format fmt pos i widths) s)
-                      (succ i))
-    | 'c' | 'C' as conv ->
-        Obj.magic (fun (c: char) ->
-          if conv = 'c'
-          then cont_s (String.make 1 c) (succ i)
-          else cont_s ("'" ^ Char.escaped c ^ "'") (succ i))
-    | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' ->
-        Obj.magic(fun (n: int) ->
-          cont_s (format_int (extract_format fmt pos i widths) n) (succ i))
-    | 'f' | 'e' | 'E' | 'g' | 'G' ->
-        Obj.magic(fun (f: float) ->
-          cont_s (format_float (extract_format fmt pos i widths) f) (succ i))
-    | 'b' | 'B' ->
-        Obj.magic(fun (b: bool) ->
-          cont_s (string_of_bool b) (succ i))
-    | 'a' ->
-        Obj.magic (fun printer arg ->
-          cont_a printer arg (succ i))
-    | 't' ->
-        Obj.magic (fun printer ->
-          cont_t printer (succ i))
-    | 'l' ->
-        begin match String.unsafe_get fmt (succ i) with
-        | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' ->
-            Obj.magic(fun (n: int32) ->
-              cont_s (format_int32 (extract_format fmt pos (succ i) widths) n)
-                     (i + 2))
-        | _ ->
-            bad_format fmt pos
-        end
-    | 'n' ->
-        begin match String.unsafe_get fmt (succ i) with
-        | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' ->
-            Obj.magic(fun (n: nativeint) ->
-              cont_s (format_nativeint
-                         (extract_format fmt pos (succ i) widths)
-                         n)
-                     (i + 2))
-        | _ ->
-            bad_format fmt pos
-        end
-    | 'L' ->
-        begin match String.unsafe_get fmt (succ i) with
-        | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' ->
-            Obj.magic(fun (n: int64) ->
-              cont_s (format_int64 (extract_format fmt pos (succ i) widths) n)
-                     (i + 2))
-        | _ ->
-            bad_format fmt pos
-        end
-    | _ ->
-        bad_format fmt pos
-  in scan_flags [] (pos + 1)
-
-let cprintf kont fmt =
-  let fmt = (Obj.magic fmt : string) in
-  let len = String.length fmt in
-  let dest = Buffer.create (len + 16) in
-  let rec doprn i =
-    if i >= len then begin
-      let res = Buffer.contents dest in
-      Buffer.reset dest;  (* just in case kprintf is partially applied *)
-      Obj.magic (kont res)
-    end else
-    match String.unsafe_get fmt i with
-    | '%' -> scan_format fmt i cont_s cont_a cont_t
-    |  c  -> Buffer.add_char dest c; doprn (succ i)
-  and cont_s s i =
-    Buffer.add_string dest s; doprn i
-  and cont_a printer arg i =
-    Buffer.add_string dest (printer () arg); doprn i
-  and cont_t printer i =
-    Buffer.add_string dest (printer ()); doprn i
-  in doprn 0
+        Unix.tm_hour = tm_hour; Unix.tm_min = tm_min; Unix.tm_sec = tm_sec } = t
+  in
+  Printf.sprintf "%4d/%02d/%02d %02d:%02d:%02d " (tm_year+1900) (tm_mon+1) tm_mday tm_hour tm_min tm_sec
 
 let lprintf_handler = ref (fun s time ->
       Printf.printf "%sMessage [%s] discarded\n" time s;
   )
 
-let lprintf fmt =
-  cprintf (fun s -> try !lprintf_handler "" s with _ -> ())
-  (fmt : ('a,unit, unit) format )
-
-let lprintf2 m fmt =
-  cprintf (fun s -> try !lprintf_handler (log_time ()) (m^" "^s) with _ -> ())
-  (fmt : ('a,unit, unit) format )
-
-let lprintf_nl fmt =
-  cprintf (fun s -> try !lprintf_handler (log_time ()) (s^"\n") with _ -> ())
-  (fmt : ('a,unit, unit) format )
-
-let lprintf_nl2 m fmt =
-  cprintf (fun s -> try !lprintf_handler (log_time ()) (m^" "^s^"\n") with _ -> ())
-  (fmt : ('a,unit, unit) format )
+let lprintf fmt = Printf.ksprintf (fun s -> try !lprintf_handler "" s with _ -> ()) fmt
+let lprintf2 m fmt = Printf.ksprintf (fun s -> try !lprintf_handler (log_time ()) (m^" "^s) with _ -> ()) fmt
+let lprintf_nl fmt = Printf.ksprintf (fun s -> try !lprintf_handler (log_time ()) (s^"\n") with _ -> ()) fmt
+let lprintf_nl2 m fmt = Printf.ksprintf (fun s -> try !lprintf_handler (log_time ()) (m^" "^s^"\n") with _ -> ()) fmt
 
 let lprint_newline () = lprintf "\n"
 let lprint_char = lprintf "%c"
@@ -234,13 +60,13 @@ let keep_console_output () =
     Some c when c = stderr || c = stdout -> true
   | _ -> false
 
-let _ =
+let () =
   set_lprintf_handler (fun time s ->
       (match !syslog_oc with
-	None -> ()
+      | None -> ()
       | Some oc -> Syslog.syslog oc `LOG_INFO s);
       match !lprintf_output with
-        Some out when !lprintf_to_channel ->
+      | Some out when !lprintf_to_channel ->
           Printf.fprintf out "%s" (time ^ s); flush out
       | _ ->
           if !lprintf_size >= !lprintf_max_size then
diff --git a/src/utils/cdk/printf2.mli b/src/utils/cdk/printf2.mli
index 97d164ea..74936982 100644
--- a/src/utils/cdk/printf2.mli
+++ b/src/utils/cdk/printf2.mli
@@ -25,21 +25,17 @@ val lprintf_original_output : out_channel option ref
 val keep_console_output : unit -> bool
 
 val log_time : unit -> string
-val cprintf : (string -> unit) -> ('a, unit, unit) format -> 'a
-(** [cprintf k format arguments] is the same as [printf format arguments],
-    except that the resulting string is passed as argument to [k]; the
-    result of [k] is then returned as the result of [cprintf]. *)
-
-val lprintf :  ('a, unit, unit) format -> 'a
-val lprintf2 :  string -> ('a, unit, unit) format -> 'a
-val lprintf_nl :  ('a, unit, unit) format -> 'a
-val lprintf_nl2 : string -> ('a, unit, unit) format -> 'a
-val lprint_newline : unit -> unit  
-val lprint_char : char -> unit  
-val lprint_string : string -> unit  
-val lprint_int : int -> unit  
+
+val lprintf :  ('a, unit, string, unit) format4 -> 'a
+val lprintf2 :  string -> ('a, unit, string, unit) format4 -> 'a
+val lprintf_nl :  ('a, unit, string, unit) format4 -> 'a
+val lprintf_nl2 : string -> ('a, unit, string, unit) format4 -> 'a
+val lprint_newline : unit -> unit
+val lprint_char : char -> unit
+val lprint_string : string -> unit
+val lprint_int : int -> unit
 val lprintf_max_size : int ref
-  
+
 val detach : unit -> unit
 val log_to_file : out_channel -> unit
 val log_to_buffer : Buffer.t -> unit
diff --git a/src/utils/lib/gettext.ml4 b/src/utils/lib/gettext.ml4
index 60cf3102..91a9fbbe 100644
--- a/src/utils/lib/gettext.ml4
+++ b/src/utils/lib/gettext.ml4
@@ -236,8 +236,8 @@ let _ss : string _string -> string = fun m ->
 
 let _s modname (x : string) = _ss (ss_ modname x)
 
-let bb_ : string -> ('a, 'b, 'c) format -> ('a, 'b, 'c) format _string = fun modname -> Obj.magic (ss_ modname)
-let _bb : ('a, 'b, 'c) format _string -> ('a, 'b, 'c) format = fun m ->
+let bb_ : string -> ('a, 'b, 'c, 'd) format4 -> ('a, 'b, 'c, 'd) format4 _string = fun modname -> Obj.magic (ss_ modname)
+let _bb : ('a, 'b, 'c, 'd) format4 _string -> ('a, 'b, 'c, 'd) format4 = fun m ->
   let index = m.index in
   !requests.(index) <- !requests.(index) + 1;
   let translation = !translation.(index) in
diff --git a/src/utils/lib/gettext.mli b/src/utils/lib/gettext.mli
index f642b232..6ac31be9 100644
--- a/src/utils/lib/gettext.mli
+++ b/src/utils/lib/gettext.mli
@@ -19,5 +19,5 @@
 
 val set_strings_file : string -> unit
 
-val _b : string -> ('a, 'b, 'c) format -> ('a, 'b, 'c) format
+val _b : string -> ('a, 'b, 'c, 'd) format4 -> ('a, 'b, 'c, 'd) format4
 val _s : string -> string -> string
-- 
2.11.4.GIT