← Back to branch summary

~ubuntu-branches/ubuntu/quantal/laby/quantal

« back to all changes in this revision

Viewing changes to src/dtools/fd.ml

  • Committer: Package Import Robot
  • Author(s): Mehdi Dogguy
  • Date: 2011-09-26 14:09:54 UTC
  • mfrom: (7.1.1 sid)
  • Revision ID: package-import@ubuntu.com-20110926140954-om8rcdmy6hsnm6dy
Tags: 0.6.3-1
* New upstream release
* Switch to 3.0 (quilt) source format.
* Bump Standards-Version to 3.9.2, no changes required.

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/dtools/fd.ml
1
1
(*
2
 
   Copyright (C) 2007-2009 Stéphane Gimenez
 
2
   Copyright (C) 2007-2010 Stéphane Gimenez
3
3
   You have permission to copy, modify, and redistribute under the
4
4
   terms of the GPL-3.0. For full license terms, see gpl-3.0.txt.
5
5
*)
12
12
let conf_tags =
13
13
  Conf.void (F.x "theme" [])
14
14
 
15
 
let texts : (string * string, (string * F.t) list -> F.t) Hashtbl.t =
 
15
let texts : (string * string, string * ((string * F.t) list -> F.t)) Hashtbl.t =
16
16
  Hashtbl.create 1024
17
17
 
18
18
let env_term =
19
19
  begin try Some (Sys.getenv "TERM") with Not_found -> None end
20
20
 
21
 
let escape c = "\027[" ^ c ^ "m", "\027[0m"
 
21
let escape =
 
22
  begin match env_term with
 
23
  | Some ("xterm" | "xterm-color"
 
24
    | "rxvt-256color" | "rxvt-unicode" | "rxvt") ->
 
25
      (fun c -> "\027[" ^ c ^ "m", "\027[0m")
 
26
  | _ -> (fun _ -> "", "")
 
27
  end
22
28
 
23
29
let color, bcolor =
24
30
  begin match env_term with
71
77
  in
72
78
  let tstr = ref None in
73
79
  let tag m =
74
 
    if !tstr = None then
 
80
    (* if !tstr = None then *)
75
81
      tstr := Some (String.concat ";" (List.map codes c#get));
76
82
    begin match !tstr with
77
83
    | Some tstr when tstr <> "" ->
93
99
  fun vars ->
94
100
    F.h [tag_msg_bad (F.s "<!>"); F.s (snd key); F.v (List.map arg vars)]
95
101
 
96
 
let def_text key str =
97
 
  let str = str ^ "\n" in
98
 
  let state = ref `Elem in
99
 
  let p = ref 0 in
100
 
  let elem = ref "" in
101
 
  let arg = ref "" in
102
 
  let push c str = str := !str ^ String.make 1 c in
103
 
  let l = ref [] in
104
 
  let add_elem () =
105
 
    if !elem <> "" then  l := !l @ [ `Elem !elem ]; elem := ""
106
 
  in
107
 
  let add_arg () = l := !l @ [ `Arg !arg ]; arg := "" in
108
 
  let eos = String.length str in
109
 
  while !p < eos do state :=
110
 
    begin match !state, str.[!p] with
111
 
    | `Elem, '<' -> incr p; add_elem (); `Arg
112
 
    | `Elem, '\n' -> incr p; add_elem (); `Elem
113
 
    | `Elem, c -> push c elem; incr p; `Elem
114
 
    | `Arg, '>' -> incr p; add_arg (); `Elem
115
 
    | `Arg, '\n' -> `Error
116
 
    | `Arg, c -> push c arg; incr p; `Arg
117
 
    | `Error, _ -> p := eos; `Error
118
 
    end
119
 
  done;
120
 
  let list = !l in
121
 
  begin match !state with
122
 
  | `Elem ->
 
102
let list_of_string s =
 
103
  let rec aux x s l =
 
104
    if x < 0 then l else aux (x - 1) s (s.[x] :: l)
 
105
  in
 
106
  aux (String.length s - 1) s []
 
107
 
 
108
let get_text_locale key =
 
109
  try fst (Hashtbl.find texts key) with Not_found -> ""
 
110
 
 
111
let def_text key (locale, str) =
 
112
  let b = Buffer.create 256 in
 
113
  let push c = Buffer.add_char b c in
 
114
  let take () = let c = Buffer.contents b in Buffer.clear b; c in
 
115
  let rec elem stream out =
 
116
    begin match stream with
 
117
    | '>' :: q -> `Error
 
118
    | '<' :: q ->
 
119
        begin match take () with
 
120
        | "" -> arg q out
 
121
        | s -> arg q (`Elem s :: out)
 
122
        end
 
123
    | '\n' :: q -> `Error
 
124
    |  c :: q -> push c; elem q out
 
125
    | _ ->
 
126
        let l =
 
127
          begin match take () with
 
128
          | "" -> out
 
129
          | s -> `Elem s :: out
 
130
          end
 
131
        in `Ok (List.rev l)
 
132
    end
 
133
  and arg stream out =
 
134
    begin match stream with
 
135
    | '>' :: q ->
 
136
        begin match take () with
 
137
        | "" -> elem q out
 
138
        | s -> elem q (`Arg s :: out)
 
139
        end
 
140
    | '<' :: q -> `Error
 
141
    | '\n' :: q -> `Error
 
142
    |  c :: q -> push c; arg q out
 
143
    | _ -> `Error
 
144
    end
 
145
  in
 
146
  begin match elem (list_of_string str) [] with
 
147
  | `Ok list ->
123
148
      let msg vars =
124
149
        let map =
125
150
          begin function
130
155
              end
131
156
          end
132
157
        in
133
 
        F.h ~sep:F.n (List.map map list)
 
158
        F.b (List.map map list)
134
159
      in
135
 
      Hashtbl.add texts key msg
 
160
      Hashtbl.add texts key (locale, msg)
136
161
  | `Error ->
137
 
      Hashtbl.add texts key (bad key)
138
 
  | _ -> assert false
 
162
      Hashtbl.add texts key (locale, bad key)
139
163
  end
140
164
 
141
165
let string format t =
191
215
        let key = (special, mstr) in
192
216
        let t =
193
217
          begin try
194
 
            begin try (Hashtbl.find texts key) vars with
 
218
            begin try (snd (Hashtbl.find texts key)) vars with
195
219
            | Not_found ->
196
 
                def_text key mstr;
197
 
                (Hashtbl.find texts key) vars
 
220
                def_text key ("", mstr);
 
221
                (snd (Hashtbl.find texts key)) vars
198
222
            end
199
223
          with
200
224
          | Not_found -> bad key vars
215
239
            date.Unix.tm_hour date.Unix.tm_min date.Unix.tm_sec
216
240
        in
217
241
        add state stime
218
 
    | `Exn e ->
219
 
        add state (Printexc.to_string e)
 
242
    | `Exn (bt, e) ->
 
243
        if bt = ""
 
244
        then add state (Printexc.to_string e)
 
245
        else
 
246
          let fbt =
 
247
            F.v (List.map F.s (Str.split (Str.regexp_string "\n") bt))
 
248
          in
 
249
          str (F.h [F.s (Printexc.to_string e); fbt]) state
220
250
    | `Lazy fn ->
221
251
        str (fn ()) state
222
252
    | _ -> add state "<unknown>"