Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 260 lines (247 sloc) 12.059 kB
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 (** implementation of debugTracer : cf mli file
19 @author Mathieu Barbin samedi 18 avril 2009, 15:35:35 (UTC+0100) *)
20
21 let tm () = Unix.localtime (Unix.time ())
22
23 let d2 n =
24 let d = n / 10 and u = n mod 10 in
25 Printf.sprintf "%d%d" d u
26
27 let year () =
28 let t = Unix.localtime (Unix.time ()) in
29 ("20"^(d2 (t.Unix.tm_year mod 100)))
30
31 let now ?time () =
32 let t = Unix.localtime (match time with Some t -> t | _ -> Unix.time ()) in
33 Printf.sprintf "%s/%s/%s - %s:%s:%s"
34 (d2 t.Unix.tm_mday)
35 (d2 (t.Unix.tm_mon + 1))
36 (d2 (t.Unix.tm_year mod 100))
37 (d2 t.Unix.tm_hour)
38 (d2 t.Unix.tm_min)
39 (d2 t.Unix.tm_sec)
40
41 let htmlescaped =
42 let f = function
43 | '<' -> "&lt;" | '>' -> "&gt;" | '&' -> "&amp;" | '\'' -> "&apos;" | '\"' -> "&quot;" | c -> String.make 1 c in
44 fun s ->
45 let len = String.length s in
46 (* let rec fold buf i = if i >= len then FBuffer.contents buf else fold (FBuffer.add buf (f (String.unsafe_get s i))) (succ i) in *)
47 (* fold (FBuffer.create 1024) 0 *)
48 let rec fold buf i =
49 if i >= len then
50 FBuffer.contents buf
51 else
52 let c = String.unsafe_get s i in
53 if c = '\027' && i + 3 < len && (String.unsafe_get s (i+1)) = '[' then
54 if (String.unsafe_get s (i+2)) = '0' then
55 fold (FBuffer.add buf "</span>") (i+4)
56 else
57 let color_type = if (String.unsafe_get s (i+2)) = '4' then "background" else "foreground" in
58 let color_name = Ansi.string_of_color (Ansi.uncolor (int_of_string (String.make 1 (String.unsafe_get s (i+3))))) in
59 fold (FBuffer.add buf (Printf.sprintf "<span class=\"%s_color_%s\">" color_type color_name)) (i+5)
60 else
61 fold (FBuffer.add buf (f c)) (i+1)
62 in
63 fold (FBuffer.create 1024) 0
64
65 #<< type data = string >>#;
66 #<< module Debug = >>#;
67 #<< struct >>#;
68 #<< type id = int * string >>#;
69 #<< type t = string * data list >>#;
70 #<< type tree = (id * t list) list >>#;
71 #<< let fresh = let t = ref (-1) in (fun s -> incr(t); (!t, s)) >>#;
72 #<< let compare (a, _) (b, _) = Pervasives.compare a b >>#;
73 #<< let create = fresh >>#;
74 #<< let to_string (_, s) = s >>#;
75 #<< let warning = fresh "warnings" >>#;
76 #<< let error = fresh "errors" >>#;
77 #<< let info = fresh "infos (verbose)" >>#;
78 #<< end >>#;
79 #<< module type DEBUGTRACER = sig val ext : string list val generate : libname:string -> libversion:string -> Debug.tree -> (string * string) list end >>#;
80 #<< module type SPEDEBUGTRACER = sig val ext : string val generator : libname:string -> libversion:string -> Debug.tree -> (string * string) end >>#;
81 #<< module EmptyTracer : DEBUGTRACER = struct let ext = [] let generate ~libname:_ ~libversion:_ _ = [] end >>#;
82 #<< module AddTracer (Tracer : DEBUGTRACER) (Spe : SPEDEBUGTRACER) : DEBUGTRACER = >>#;
83 #<< struct >>#;
84 #<< let ext = Spe.ext::Tracer.ext >>#;
85 #<< let generate ~libname ~libversion tree = (Spe.generator ~libname ~libversion tree)::(Tracer.generate ~libname ~libversion tree) >>#;
86 #<< end >>#;
87 #<< module HTMLTracer : SPEDEBUGTRACER = >>#;
88 #<< struct >>#;
89 #<< let _begin = " >>#;
90 #<< <html> >>#;
91 #<< <head> >>#;
92 #<< <title>debug output - MLstate (c) 2009</title> >>#;
93 #<< <link rel=\"stylesheet\" type=\"text/css\" href=\"/shared/debugstyle.css\" /> >>#;
94 #<< <link rel=\"stylesheet\" type=\"text/css\" href=\"/shared/ocaml/lib/debugstyle.css \" /> >>#;
95 #<< <link rel=\"stylesheet\" type=\"text/css\" href=\"/shared/ocaml/lib64/debugstyle.css \" /> >>#;
96 #<< <link rel=\"stylesheet\" type=\"text/css\" href=\"debugstyle.css\" /> >>#;
97 #<< </head> >>#;
98 #<< <body> >>#;
99 #<< " >>#;
100 #<< let uib = Printf.sprintf "<u><i>%s</i></u>" >>#;
101 #<< let cont = uib "back to contents" let ppred = uib "pred" let nnext = uib "next" >>#;
102 #<< let href = Printf.sprintf "<a href=\"#%d\">%s</a>" >>#;
103 #<< let name = Printf.sprintf "<a name=\"%d\">%s</a>" >>#;
104 #<< let hh i s = Printf.sprintf "<h%d>%s</h%d>" i s i >>#;
105 #<< let _end = " >>#;
106 #<< </body> >>#;
107 #<< </html>" >>#;
108 #<< let ext = "html" >>#;
109 #<< let labelm = let t = ref 0 in fun () -> incr(t); !t >>#;
110 #<< let generator ~libname ~libversion tree = >>#;
111 #<< let fold_item (pp, buf, link) (m, lmess) = >>#;
112 #<< let label = labelm () in >>#;
113 #<< let buf = FBuffer.addln buf (Printf.sprintf "<li>%s %s %s %s <pre>" (name label ("Module "^(String.capitalize m))) (href pp ppred) (href (succ label) nnext) (href 0 cont)) in >>#;
114 #<< let buf = List.fold_left (fun buf m -> FBuffer.addln buf (htmlescaped m)) buf lmess in >>#;
115 #<< let buf = FBuffer.addln buf "</pre></li>" in >>#;
116 #<< let link = FBuffer.addln link (Printf.sprintf "<li>%s</li>" (href label ("module "^(String.lowercase m)))) in >>#;
117 #<< label, buf, link in >>#;
118 #<< let fold_id (buf, link) (id, items) = >>#;
119 #<< let label = labelm () and idd = Debug.to_string id in >>#;
120 #<< let buf = FBuffer.addln buf ((name label (hh 2 (String.capitalize idd)))^"<ul>") in >>#;
121 #<< let link = FBuffer.addln link ((href label (String.lowercase idd))^"<ul>") in >>#;
122 #<< let _, buf, link = List.fold_left fold_item (pred label, buf, link) items in >>#;
123 #<< let buf = FBuffer.addln buf "</ul>" and link = FBuffer.addln link "</ul>" in buf, link in >>#;
124 #<< let tree_debug, link = List.fold_left fold_id ((FBuffer.create 1024), (FBuffer.create 1024)) tree in >>#;
125 #<< ext, >>#;
126 #<< List.fold_left (^) "" >>#;
127 #<< [ >>#;
128 #<< _begin; >>#;
129 #<< Printf.sprintf "<h1>Debug Tracer Interface for %s version %s</h1>" libname libversion; >>#;
130 #<< Printf.sprintf "<h2>Date of this diagnosis : %s</h2>\n" (now ()); >>#;
131 #<< "<small>\n"; >>#;
132 #<< name 0 (hh 4 "contents :"); >>#;
133 #<< FBuffer.contents link; >>#;
134 #<< "</small>\n"; >>#;
135 #<< FBuffer.contents tree_debug; >>#;
136 #<< _end >>#;
137 #<< ] >>#;
138 #<< end >>#;
139 #<< module DebugTracer : DEBUGTRACER = AddTracer(EmptyTracer)(HTMLTracer) >>#;
140 module type DEBUGINTERFACE =
141 sig
142 val error : ?ending:(string -> 'a) -> ?color:Ansi.color -> string -> string -> 'a
143 val warning : string -> ?color:Ansi.color -> string -> unit
144 val verbose : string -> ?color:Ansi.color -> string -> unit
145 val withcolor : bool -> unit
146 val whisper : string -> unit
147
148 #<< val debug : string -> Debug.id -> string -> unit >>#;
149 #<< val set_trace_prefix : string -> unit >>#;
150 #<< val trace : ?verbose:bool -> unit -> unit >>#;
151 #<< val suspend : unit -> unit >>#;
152 #<< val active : unit -> unit >>#;
153 #<< val is_active : unit -> bool >>#;
154 end
155 module type INTERFACEPARAMETER =
156 sig
157 val libname : string val version : string val quiet : unit -> bool
158 module DefaultColor :
159 sig
160 val error : Ansi.color
161 val warning : Ansi.color
162 val verbose : Ansi.color
163 val withcolor : bool
164 end
165 end
166 (** We got it : thanks to Mehdi who find the info on ocaml logs that ocaml has random bug with systhread *)
167 module MakeDebugInterface (P : INTERFACEPARAMETER)
168 #<< (DebugTracer : DEBUGTRACER) >>#;
169 =
170 struct
171 #<< (* imperative structurs of logs *) >>#;
172 #<< let this_id = Printf.sprintf "%s-DebugInterface" P.libname >>#;
173 #<< module DebugTable : >>#;
174 #<< sig >>#;
175 #<< val add : Debug.id -> string -> string -> unit >>#;
176 #<< val build_tree : unit -> Debug.tree >>#;
177 #<< val reset : unit -> unit >>#;
178 #<< end = >>#;
179 #<< struct >>#;
180 #<< let _table = SortHashtbl.create 10 >>#;
181 #<< let reset () = SortHashtbl.clear _table >>#;
182 #<< let init_module mess = [mess] >>#;
183 #<< let init_id id = SortHashtbl.add _table id (SortHashtbl.create 10) >>#;
184 #<< let add id mo mess = >>#;
185 #<< match SortHashtbl.find_opt _table id with >>#;
186 #<< | None -> >>#;
187 #<< let items = SortHashtbl.create 10 in >>#;
188 #<< let allmess = init_module mess in >>#;
189 #<< SortHashtbl.replace items mo allmess; >>#;
190 #<< SortHashtbl.replace _table id items >>#;
191 #<< | Some items -> >>#;
192 #<< let was = Option.default [] (SortHashtbl.find_opt items mo) in >>#;
193 #<< SortHashtbl.replace items mo (mess::was) >>#;
194 #<< let build_tree () = >>#;
195 #<< let fold_item mo allmess ac = (mo, List.rev allmess)::ac in >>#;
196 #<< let fold id items ac = >>#;
197 #<< let mitems = SortHashtbl.fold_right fold_item items [] in >>#;
198 #<< (id, mitems)::ac in >>#;
199 #<< SortHashtbl.fold_right fold _table [] >>#;
200 #<< let _ = List.iter init_id [Debug.error; Debug.warning; Debug.info] >>#;
201 #<< end >>#;
202 let _with_color = ref P.DefaultColor.withcolor
203 let withcolor t = _with_color := t
204 #<< let suspend, active, is_active = >>#;
205 #<< let _state = ref false in >>#;
206 #<< (fun () -> _state := false), (fun () -> _state := true), (fun () -> !_state) >>#;
207 let plot
208 #<< debugid >>#;
209 prefix _module ?(color=`black) m =
210 let message = Base.String.replace m "\n" "\n\t" in
211 #<< (if is_active () then DebugTable.add debugid _module message); >>#;
212 let m = Printf.sprintf "%s%s : %s" prefix _module message in
213 if !_with_color then Ansi.print color m else m
214 let warning _mo ?(color=P.DefaultColor.warning) m =
215 if P.quiet () then
216 ()
217 else
218 prerr_endline (plot
219 #<< Debug.warning >>#;
220 "warning " _mo ~color m)
221 let verbose _mo ?(color=P.DefaultColor.verbose) m =
222 if P.quiet () then
223 ()
224 else
225 prerr_endline (plot
226 #<< Debug.info >>#;
227 "" _mo ~color m)
228 let verboze = verbose
229 (* partial application for modules -- including thread denomination *)
230 #<< let debug mo id m = if is_active () then >>#;
231 #<< (* let extrath = let t = Thread.id (Thread.self ()) in if t = 0 then "" else Printf.sprintf "[th-%d]: " t in *) >>#;
232 #<< DebugTable.add id mo (Base.String.replace m "\n" "\n\t") >>#;
233 #<< let plurial, debug_ext = match DebugTracer.ext with >>#;
234 #<< | [t] -> "", "."^t >>#;
235 #<< | _::_ as l -> "s", "{"^(String.concat ", " l)^"}" >>#;
debb5ea [cleanup] Base: remove error
Raja authored
236 #<< | _ -> failwith (Printf.sprintf "%s has no tracer-module implemented, and that is sad !" this_id) >>#;
fccc685 Initial open-source release
MLstate authored
237 #<< let _prefix = ref ((String.lowercase P.libname)^"diagnostic") >>#;
238 #<< let set_trace_prefix s = _prefix := s >>#;
239 #<< let trace ?(verbose=true) () = >>#;
240 #<< (if verbose then verboze this_id (Printf.sprintf "for more debug info, see the file%s %s%s generated for you" plurial !_prefix debug_ext)); >>#;
241 #<< let tree = DebugTable.build_tree () in >>#;
242 #<< let debug_files = DebugTracer.generate ~libname:P.libname ~libversion:P.version tree in >>#;
243 #<< List.iter (fun (ext, contents) -> >>#;
244 #<< let filename = !_prefix^"."^ext in >>#;
245 #<< try let oc = open_out filename in output_string oc contents; close_out oc with >>#;
246 #<< _ -> verboze this_id ~color:P.DefaultColor.error (Printf.sprintf "cannot generate debug-diagnosis file %s" filename) >>#;
247 #<< ) debug_files >>#;
248 let error ?(ending=fun (_:string) -> exit 1) ?(color=P.DefaultColor.error) _mo m =
249 prerr_endline (plot
250 #<< Debug.error >>#;
251 "[!] " _mo ~color m); ending m
252 #<< let _ = at_exit (fun () -> if is_active () then trace ()) >>#;
253
254 let whisper m =
255 if P.quiet () then
256 ()
257 else
258 print_endline m
259 end
Something went wrong with that request. Please try again.