src/utils/cdk/printf2.ml

   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
  21 open Autoconf
  22 open Syslog
  23
  24 let syslog_oc = ref None
  25
  26 external format_int: string -> int -> string = "caml_format_int"
  27 external format_int32: string -> int32 -> string = "caml_int32_format"
  28 external format_nativeint: string -> nativeint -> string = "caml_nativeint_format"
  29 external format_int64: string -> int64 -> string = "caml_int64_format"
  30 external format_float: string -> float -> string = "caml_format_float"
  31
  32 let log_time () =
  33 let t = Unix.localtime (Unix.time ()) in
  34   let { Unix.tm_year = tm_year; Unix.tm_mon = tm_mon; Unix.tm_mday = tm_mday;
  35         Unix.tm_hour = tm_hour; Unix.tm_min = tm_min; Unix.tm_sec = tm_sec } = t in
  36     Printf.sprintf "%4d/%02d/%02d %02d:%02d:%02d " (tm_year+1900) (tm_mon+1) tm_mday tm_hour tm_min tm_sec
  37
  38 let bad_format fmt pos =
  39   invalid_arg
  40     ("printf: bad format " ^ String.sub fmt pos (String.length fmt - pos))
  41
  42 (* Format a string given a %s format, e.g. %40s or %-20s.
  43    To do: ignore other flags (#, +, etc)? *)
  44
  45 let format_string format s =
  46   let rec parse_format neg i =
  47     if i >= String.length format then (0, neg) else
  48     match String.unsafe_get format i with
  49     | '1'..'9' ->
  50         (int_of_string (String.sub format i (String.length format - i - 1)),
  51          neg)
  52     | '-' ->
  53         parse_format true (succ i)
  54     | _ ->
  55         parse_format neg (succ i) in
  56   let (p, neg) =
  57     try parse_format false 1 with Failure _ -> bad_format format 0 in
  58   if String.length s < p then begin
  59     let res = String.make p ' ' in
  60     if neg
  61     then String.blit s 0 res 0 (String.length s)
  62     else String.blit s 0 res (p - String.length s) (String.length s);
  63     res
  64   end else
  65     s
  66
  67 (* Extract a %format from [fmt] between [start] and [stop] inclusive.
  68    '*' in the format are replaced by integers taken from the [widths] list.
  69    The function is somewhat optimized for the "no *" case. *)
  70
  71 let extract_format fmt start stop widths =
  72   match widths with
  73   | [] -> String.sub fmt start (stop - start + 1)
  74   | _  ->
  75       let b = Buffer.create (stop - start + 10) in
  76       let rec fill_format i w =
  77         if i > stop then Buffer.contents b else
  78           match (String.unsafe_get fmt i, w) with
  79             ('*', h::t) ->
  80               Buffer.add_string b (string_of_int h); fill_format (succ i) t
  81           | ('*', []) ->
  82               bad_format fmt start (* should not happen *)
  83           | (c, _) ->
  84               Buffer.add_char b c; fill_format (succ i) w
  85       in fill_format start (List.rev widths)
  86
  87 (* Decode a %format and act on it.
  88    [fmt] is the printf format style, and [pos] points to a [%] character.
  89    After consuming the appropriate number of arguments and formatting
  90    them, one of the three continuations is called:
  91    [cont_s] for outputting a string (args: string, next pos)
  92    [cont_a] for performing a %a action (args: fn, arg, next pos)
  93    [cont_t] for performing a %t action (args: fn, next pos)
  94    "next pos" is the position in [fmt] of the first character following
  95    the %format in [fmt]. *)
  96
  97 (* Note: here, rather than test explicitly against [String.length fmt]
  98    to detect the end of the format, we use [String.unsafe_get] and
  99    rely on the fact that we'll get a "nul" character if we access
 100    one past the end of the string.  These "nul" characters are then
 101    caught by the [_ -> bad_format] clauses below.
 102    Don't do this at home, kids. *)
 103
 104 let scan_format fmt pos cont_s cont_a cont_t =
 105   let rec scan_flags widths i =
 106     match String.unsafe_get fmt i with
 107     | '*' ->
 108         Obj.magic(fun w -> scan_flags (w :: widths) (succ i))
 109     | '0'..'9' | '.' | '#' | '-' | ' ' | '+' -> scan_flags widths (succ i)
 110     | _ -> scan_conv widths i
 111   and scan_conv widths i =
 112     match String.unsafe_get fmt i with
 113     | '%' ->
 114         cont_s "%" (succ i)
 115     | 's' | 'S' as conv ->
 116         Obj.magic (fun (s: string) ->
 117           let s = if conv = 's' then s else "\"" ^ String.escaped s ^ "\"" in
 118           if i = succ pos (* optimize for common case %s *)
 119           then cont_s s (succ i)
 120           else cont_s (format_string (extract_format fmt pos i widths) s)
 121                       (succ i))
 122     | 'c' | 'C' as conv ->
 123         Obj.magic (fun (c: char) ->
 124           if conv = 'c'
 125           then cont_s (String.make 1 c) (succ i)
 126           else cont_s ("'" ^ Char.escaped c ^ "'") (succ i))
 127     | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' ->
 128         Obj.magic(fun (n: int) ->
 129           cont_s (format_int (extract_format fmt pos i widths) n) (succ i))
 130     | 'f' | 'e' | 'E' | 'g' | 'G' ->
 131         Obj.magic(fun (f: float) ->
 132           cont_s (format_float (extract_format fmt pos i widths) f) (succ i))
 133     | 'b' | 'B' ->
 134         Obj.magic(fun (b: bool) ->
 135           cont_s (string_of_bool b) (succ i))
 136     | 'a' ->
 137         Obj.magic (fun printer arg ->
 138           cont_a printer arg (succ i))
 139     | 't' ->
 140         Obj.magic (fun printer ->
 141           cont_t printer (succ i))
 142     | 'l' ->
 143         begin match String.unsafe_get fmt (succ i) with
 144         | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' ->
 145             Obj.magic(fun (n: int32) ->
 146               cont_s (format_int32 (extract_format fmt pos (succ i) widths) n)
 147                      (i + 2))
 148         | _ ->
 149             bad_format fmt pos
 150         end
 151     | 'n' ->
 152         begin match String.unsafe_get fmt (succ i) with
 153         | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' ->
 154             Obj.magic(fun (n: nativeint) ->
 155               cont_s (format_nativeint
 156                          (extract_format fmt pos (succ i) widths)
 157                          n)
 158                      (i + 2))
 159         | _ ->
 160             bad_format fmt pos
 161         end
 162     | 'L' ->
 163         begin match String.unsafe_get fmt (succ i) with
 164         | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' ->
 165             Obj.magic(fun (n: int64) ->
 166               cont_s (format_int64 (extract_format fmt pos (succ i) widths) n)
 167                      (i + 2))
 168         | _ ->
 169             bad_format fmt pos
 170         end
 171     | _ ->
 172         bad_format fmt pos
 173   in scan_flags [] (pos + 1)
 174
 175 let cprintf kont fmt =
 176   let fmt = (Obj.magic fmt : string) in
 177   let len = String.length fmt in
 178   let dest = Buffer.create (len + 16) in
 179   let rec doprn i =
 180     if i >= len then begin
 181       let res = Buffer.contents dest in
 182       Buffer.reset dest;  (* just in case kprintf is partially applied *)
 183       Obj.magic (kont res)
 184     end else
 185     match String.unsafe_get fmt i with
 186     | '%' -> scan_format fmt i cont_s cont_a cont_t
 187     |  c  -> Buffer.add_char dest c; doprn (succ i)
 188   and cont_s s i =
 189     Buffer.add_string dest s; doprn i
 190   and cont_a printer arg i =
 191     Buffer.add_string dest (printer () arg); doprn i
 192   and cont_t printer i =
 193     Buffer.add_string dest (printer ()); doprn i
 194   in doprn 0
 195
 196 let lprintf_handler = ref (fun s time ->
 197       Printf.printf "%sMessage [%s] discarded\n" time s;
 198   )
 199
 200 let lprintf fmt =
 201   cprintf (fun s -> try !lprintf_handler "" s with _ -> ())
 202   (fmt : ('a,unit, unit) format )
 203
 204 let lprintf2 m fmt =
 205   cprintf (fun s -> try !lprintf_handler (log_time ()) (m^" "^s) with _ -> ())
 206   (fmt : ('a,unit, unit) format )
 207
 208 let lprintf_nl fmt =
 209   cprintf (fun s -> try !lprintf_handler (log_time ()) (s^"\n") with _ -> ())
 210   (fmt : ('a,unit, unit) format )
 211
 212 let lprintf_nl2 m fmt =
 213   cprintf (fun s -> try !lprintf_handler (log_time ()) (m^" "^s^"\n") with _ -> ())
 214   (fmt : ('a,unit, unit) format )
 215
 216 let lprint_newline () = lprintf "\n"
 217 let lprint_char = lprintf "%c"
 218 let lprint_int = lprintf "%d"
 219 let lprint_string = lprintf "%s"
 220
 221 let set_lprintf_handler f =
 222   lprintf_handler := f
 223
 224 let lprintf_max_size = ref 100
 225 let lprintf_size = ref 0
 226 let lprintf_fifo = Fifo.create ()
 227 let lprintf_to_channel = ref true
 228
 229 let lprintf_output = ref (Some stderr)
 230 let lprintf_original_output = ref None
 231
 232 let keep_console_output () =
 233   match !lprintf_original_output with
 234     Some c when c = stderr || c = stdout -> true
 235   | _ -> false
 236
 237 let _ =
 238   set_lprintf_handler (fun time s ->
 239       (match !syslog_oc with
 240         None -> ()
 241       | Some oc -> Syslog.syslog oc `LOG_INFO s);
 242       match !lprintf_output with
 243         Some out when !lprintf_to_channel ->
 244           Printf.fprintf out "%s" (time ^ s); flush out
 245       | _ ->
 246           if !lprintf_size >= !lprintf_max_size then
 247             ignore (Fifo.take lprintf_fifo)
 248           else
 249             incr lprintf_size;
 250           Fifo.put lprintf_fifo (time ^ s)
 251   )
 252
 253 let detach () =
 254   match !lprintf_output with
 255     Some oc when oc == Pervasives.stdout -> lprintf_output := None
 256   | _ -> ()
 257
 258 let close_log () =
 259   lprintf_to_channel := false;
 260   match !lprintf_output with
 261     None -> ()
 262   | Some oc ->
 263       if oc != stderr && oc != stdout then
 264         close_out oc;
 265       lprintf_output := None
 266
 267 let log_to_file oc =
 268   close_log ();
 269   lprintf_output := Some oc;
 270   lprintf_to_channel := true
 271
 272 let log_to_buffer buf =
 273   try
 274     while true do
 275       let s = Fifo.take lprintf_fifo in
 276       decr lprintf_size;
 277       Buffer.add_string buf s
 278     done
 279   with _ -> ()
 280
 281 (* html_mods *)
 282
 283 let html_mods_commands buf n c l =
 284     (* Name Class List *)
 285     Printf.bprintf buf "\\<div class=\\\"%s\\\"\\>\\<table id=\\\"%s\\\"
 286     name=\\\"%s\\\" class=\\\"%s\\\" cellspacing=0 cellpadding=0
 287     width=\\\"100pc\\\"\\>\\<tbody\\>\\<tr\\>"
 288     c n n c;
 289     List.iter (fun (w,x,y,z)  ->
 290      (* Class Title Onclick Value *)
 291      Printf.bprintf buf "\\<td class=\\\"%s\\\"
 292      title=\\\"%s\\\" onMouseOver=\\\"mOvr(this,'mOvr1');\\\" onMouseOut=\\\"mOut(this);\\\"
 293      onClick=\\\"%s\\\" \\>%s\\</td\\>"
 294      w x y z;
 295     ) l;
 296     Printf.bprintf buf "\\</tr\\>\\</tbody\\>\\</table\\>\\</div\\>"
 297
 298 (*
 299   html_mods_commands buf "commandsTable" "commands" [
 300     ( "bu bbig", "Extend search to more servers and view results", "mSub('output','vr');", "Extend search" ) ;
 301 *)
 302
 303 type sort_kind = Num (* numeric, parse size suffixes (kMGT) *) | Str (* plain string *)
 304
 305 let html_mods_table_header buf ?(total = "0") n c l =
 306     (* Name Class List *)
 307     Printf.bprintf buf "\\<div class=\\\"%s\\\"\\>\\<table id=\\\"%s\\\" name=\\\"%s\\\" class=\\\"%s\\\" cellspacing=0 cellpadding=0\\>"
 308     c n n c;
 309     if List.length l > 0 then begin
 310         Printf.bprintf buf "\\<tr\\>";
 311         List.iter (fun (w,x,y,z)  ->
 312          let sort = match w with Num -> "1" | Str -> "0" in
 313          (* Sort Class Title Value *)
 314          Printf.bprintf buf "\\<td onClick=\\\"_tabSort(this,%s,%s);\\\" class=\\\"%s\\\" title=\\\"%s\\\"\\>%s\\</td\\>"
 315          sort total x y z;
 316         ) l;
 317         Printf.bprintf buf "\\</tr\\>"
 318       end
 319 (* Add colspan functionality to html_mods_table_header *)
 320
 321 let html_mods_table_header_colspan buf ?(total="0") n c l =
 322     (* Name Class List *)
 323     Printf.bprintf buf "\\<div class=\\\"%s\\\"\\>\\<table id=\\\"%s\\\" name=\\\"%s\\\" class=\\\"%s\\\" cellspacing=0 cellpadding=0\\>\\<tr\\>"
 324     c n n c;
 325     List.iter (fun (v,w,x,y,z)  ->
 326      (* Sort Class Title Value *)
 327      Printf.bprintf buf "\\<td colspan=%s onClick=\\\"_tabSort(this,%s,%s);\\\" class=\\\"%s\\\" title=\\\"%s\\\"\\>%s\\</td\\>"
 328      v w total x y z;
 329     ) l;
 330     Printf.bprintf buf "\\</tr\\>"
 331
 332 let html_mods_table_no_header buf n c l =
 333     (* 1 row * n cols *)
 334     (* Name Class List *)
 335     Printf.bprintf buf "\\<div class=\\\"%s\\\"\\>\\<table id=\\\"%s\\\" name=\\\"%s\\\" class=\\\"%s\\\" cellspacing=0 cellpadding=0\\>\\<tr\\>"
 336     c n n c;
 337     List.iter (fun (t,c,d)  ->
 338     (* Title Class Value *)
 339      Printf.bprintf buf "\\<td class=\\\"%s\\\" %s\\>%s\\</td\\>"
 340      c (if t <> "" then "title=\\\"" ^ t ^ "\\\"" else "") d;
 341     ) l;
 342     Printf.bprintf buf "\\</tr\\>\\</table\\>\\</div\\>"
 343
 344 let html_mods_table_one_row buf n c l =
 345     (* 1 row * n cols *)
 346     (* Name Class List *)
 347     Printf.bprintf buf "\\<div class=\\\"%s\\\"\\>\\<table id=\\\"%s\\\" name=\\\"%s\\\" class=\\\"%s\\\" cellspacing=0 cellpadding=0\\>\\<tr\\>"
 348     c n n c;
 349     List.iter (fun (t,c,d)  ->
 350     (* Title Class Value *)
 351      Printf.bprintf buf "\\<td class=\\\"%s\\\" %s\\>%s\\</td\\>"
 352      c (if t <> "" then "title=\\\"" ^ t ^ "\\\"" else "") d;
 353     ) l;
 354     Printf.bprintf buf "\\</tr\\>\\</table\\>\\</div\\>"
 355
 356 let html_mods_table_one_col buf n c l =
 357     (* n rows * 1 col *)
 358     (* Name Class List *)
 359     Printf.bprintf buf "\\<div class=\\\"%s\\\"\\>\\<table id=\\\"%s\\\" name=\\\"%s\\\" class=\\\"%s\\\" cellspacing=0 cellpadding=0\\>\\<tr\\>"
 360     c n n c;
 361     List.iter (fun (t,c,d)  ->
 362     (* Title Class Value *)
 363      Printf.bprintf buf "\\<tr\\>\\<td class=\\\"%s\\\" %s\\>%s\\</td\\>\\</tr\\>"
 364      c (if t <> "" then "title=\\\"" ^ t ^ "\\\"" else "") d;
 365     ) l;
 366     Printf.bprintf buf "\\</tr\\>\\</table\\>\\</div\\>"
 367
 368 let html_mods_td buf l =
 369     (* List *)
 370     List.iter (fun (t,c,d)  ->
 371     (* Title Class Value *)
 372      Printf.bprintf buf "\\<td class=\\\"%s\\\" %s\\>%s\\</td\\>"
 373      c (if t <> "" then "title=\\\"" ^ t ^ "\\\"" else "") d;
 374     ) l
 375
 376
 377 let html_mods_big_header_start buf c l =
 378   Printf.bprintf buf "\\<div class=\\\"%s\\\"\\>\\<table class=main border=0 cellspacing=0 cellpadding=0\\>\\<tr\\>\\<td\\>" c;
 379   Printf.bprintf buf "\\<table cellspacing=0 cellpadding=0 width=100%%\\>\\<tr\\>";
 380   Printf.bprintf buf "\\<td width=100%%\\>\\</td\\>";
 381   let len = List.length l in
 382   let cnt = ref 0 in
 383   List.iter (fun s ->
 384     incr cnt;
 385     Printf.bprintf buf "\\<td nowrap class=\\\"fbig%s\\\"\\>%s\\</td\\>" (if !cnt = len then " pr" else "") s;
 386   ) l;
 387   Printf.bprintf buf "\\</tr\\>\\</table\\>\\</td\\>\\</tr\\>\\<tr\\>\\<td\\>"
 388
 389 let html_mods_big_header_end buf =
 390   Printf.bprintf buf "\\</td\\>\\</tr\\>\\</table\\>\\</div\\>"
 391
 392 let html_mods_counter = ref true
 393
 394 let html_mods_cntr () =
 395     html_mods_counter := not !html_mods_counter;
 396     if !html_mods_counter then 1 else 2
 397
 398 let html_mods_cntr_init () =
 399   html_mods_counter := true
 400
 401 let print_plural_s v =
 402   if v > 1 then "s" else ""