ubuntu: Add extra suppressions for libnl.1 leaks.
[libguestfs.git] / generator / generator_utils.ml
1 (* libguestfs
2  * Copyright (C) 2009-2011 Red Hat Inc.
3  *
4  * This program is free software; you can redistribute it and/or modify
5  * it under the terms of the GNU General Public License as published by
6  * the Free Software Foundation; either version 2 of the License, or
7  * (at your option) any later version.
8  *
9  * This program is distributed in the hope that it will be useful,
10  * but WITHOUT ANY WARRANTY; without even the implied warranty of
11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
12  * GNU General Public License for more details.
13  *
14  * You should have received a copy of the GNU General Public License
15  * along with this program; if not, write to the Free Software
16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
17  *)
18
19 (* Please read generator/README first. *)
20
21 (* Useful functions.
22  * Note we don't want to use any external OCaml libraries which
23  * makes this a bit harder than it should be.
24  *)
25
26 open Unix
27 open Printf
28
29 open Generator_types
30
31 let errcode_of_ret = function
32   | RConstOptString _ ->
33       `CannotReturnError
34   | RErr | RInt _ | RBool _ | RInt64 _ ->
35       `ErrorIsMinusOne
36   | RConstString _
37   | RString _ | RBufferOut _
38   | RStringList _ | RHashtable _
39   | RStruct _ | RStructList _ ->
40       `ErrorIsNULL
41
42 let string_of_errcode = function
43   | `ErrorIsMinusOne -> "-1"
44   | `ErrorIsNULL -> "NULL"
45
46 (* Generate a uuidgen-compatible UUID (used in tests).  However to
47  * avoid having the UUID change every time we rebuild the tests,
48  * generate it as a function of the contents of the
49  * generator_actions.ml file.
50  * 
51  * Originally I thought uuidgen was using RFC 4122, but it doesn't
52  * appear to.
53  *
54  * Note that the format must be 01234567-0123-0123-0123-0123456789ab
55  *)
56 let uuidgen () =
57   let s = Digest.to_hex (Digest.file "generator/generator_actions.ml") in
58
59   (* In util-linux <= 2.19, mkswap -U cannot handle the first byte of
60    * the UUID being zero, so we artificially rewrite such UUIDs.
61    * http://article.gmane.org/gmane.linux.utilities.util-linux-ng/4273
62    *)
63   if s.[0] = '0' && s.[1] = '0' then
64     s.[0] <- '1';
65
66   String.sub s 0 8 ^ "-"
67   ^ String.sub s 8 4 ^ "-"
68   ^ String.sub s 12 4 ^ "-"
69   ^ String.sub s 16 4 ^ "-"
70   ^ String.sub s 20 12
71
72 type rstructs_used_t = RStructOnly | RStructListOnly | RStructAndList
73
74 (* Returns a list of RStruct/RStructList structs that are returned
75  * by any function.  Each element of returned list is a pair:
76  *
77  * (structname, RStructOnly)
78  *    == there exists function which returns RStruct (_, structname)
79  * (structname, RStructListOnly)
80  *    == there exists function which returns RStructList (_, structname)
81  * (structname, RStructAndList)
82  *    == there are functions returning both RStruct (_, structname)
83  *                                      and RStructList (_, structname)
84  *)
85 let rstructs_used_by functions =
86   (* ||| is a "logical OR" for rstructs_used_t *)
87   let (|||) a b =
88     match a, b with
89     | RStructAndList, _
90     | _, RStructAndList -> RStructAndList
91     | RStructOnly, RStructListOnly
92     | RStructListOnly, RStructOnly -> RStructAndList
93     | RStructOnly, RStructOnly -> RStructOnly
94     | RStructListOnly, RStructListOnly -> RStructListOnly
95   in
96
97   let h = Hashtbl.create 13 in
98
99   (* if elem->oldv exists, update entry using ||| operator,
100    * else just add elem->newv to the hash
101    *)
102   let update elem newv =
103     try  let oldv = Hashtbl.find h elem in
104          Hashtbl.replace h elem (newv ||| oldv)
105     with Not_found -> Hashtbl.add h elem newv
106   in
107
108   List.iter (
109     fun (_, (ret, _, _), _, _, _, _, _) ->
110       match ret with
111       | RStruct (_, structname) -> update structname RStructOnly
112       | RStructList (_, structname) -> update structname RStructListOnly
113       | _ -> ()
114   ) functions;
115
116   (* return key->values as a list of (key,value) *)
117   Hashtbl.fold (fun key value xs -> (key, value) :: xs) h []
118
119 let failwithf fs = ksprintf failwith fs
120
121 let unique = let i = ref 0 in fun () -> incr i; !i
122
123 let replace_char s c1 c2 =
124   let s2 = String.copy s in
125   let r = ref false in
126   for i = 0 to String.length s2 - 1 do
127     if String.unsafe_get s2 i = c1 then (
128       String.unsafe_set s2 i c2;
129       r := true
130     )
131   done;
132   if not !r then s else s2
133
134 let isspace c =
135   c = ' '
136   (* || c = '\f' *) || c = '\n' || c = '\r' || c = '\t' (* || c = '\v' *)
137
138 let triml ?(test = isspace) str =
139   let i = ref 0 in
140   let n = ref (String.length str) in
141   while !n > 0 && test str.[!i]; do
142     decr n;
143     incr i
144   done;
145   if !i = 0 then str
146   else String.sub str !i !n
147
148 let trimr ?(test = isspace) str =
149   let n = ref (String.length str) in
150   while !n > 0 && test str.[!n-1]; do
151     decr n
152   done;
153   if !n = String.length str then str
154   else String.sub str 0 !n
155
156 let trim ?(test = isspace) str =
157   trimr ~test (triml ~test str)
158
159 let rec find s sub =
160   let len = String.length s in
161   let sublen = String.length sub in
162   let rec loop i =
163     if i <= len-sublen then (
164       let rec loop2 j =
165         if j < sublen then (
166           if s.[i+j] = sub.[j] then loop2 (j+1)
167           else -1
168         ) else
169           i (* found *)
170       in
171       let r = loop2 0 in
172       if r = -1 then loop (i+1) else r
173     ) else
174       -1 (* not found *)
175   in
176   loop 0
177
178 let rec replace_str s s1 s2 =
179   let len = String.length s in
180   let sublen = String.length s1 in
181   let i = find s s1 in
182   if i = -1 then s
183   else (
184     let s' = String.sub s 0 i in
185     let s'' = String.sub s (i+sublen) (len-i-sublen) in
186     s' ^ s2 ^ replace_str s'' s1 s2
187   )
188
189 let rec string_split sep str =
190   let len = String.length str in
191   let seplen = String.length sep in
192   let i = find str sep in
193   if i = -1 then [str]
194   else (
195     let s' = String.sub str 0 i in
196     let s'' = String.sub str (i+seplen) (len-i-seplen) in
197     s' :: string_split sep s''
198   )
199
200 let files_equal n1 n2 =
201   let cmd = sprintf "cmp -s %s %s" (Filename.quote n1) (Filename.quote n2) in
202   match Sys.command cmd with
203   | 0 -> true
204   | 1 -> false
205   | i -> failwithf "%s: failed with error code %d" cmd i
206
207 let rec filter_map f = function
208   | [] -> []
209   | x :: xs ->
210       match f x with
211       | Some y -> y :: filter_map f xs
212       | None -> filter_map f xs
213
214 let rec find_map f = function
215   | [] -> raise Not_found
216   | x :: xs ->
217       match f x with
218       | Some y -> y
219       | None -> find_map f xs
220
221 let iteri f xs =
222   let rec loop i = function
223     | [] -> ()
224     | x :: xs -> f i x; loop (i+1) xs
225   in
226   loop 0 xs
227
228 let mapi f xs =
229   let rec loop i = function
230     | [] -> []
231     | x :: xs -> let r = f i x in r :: loop (i+1) xs
232   in
233   loop 0 xs
234
235 let count_chars c str =
236   let count = ref 0 in
237   for i = 0 to String.length str - 1 do
238     if c = String.unsafe_get str i then incr count
239   done;
240   !count
241
242 let explode str =
243   let r = ref [] in
244   for i = 0 to String.length str - 1 do
245     let c = String.unsafe_get str i in
246     r := c :: !r;
247   done;
248   List.rev !r
249
250 let map_chars f str =
251   List.map f (explode str)
252
253 let name_of_argt = function
254   | Pathname n | Device n | Dev_or_Path n | String n | OptString n
255   | StringList n | DeviceList n | Bool n | Int n | Int64 n
256   | FileIn n | FileOut n | BufferIn n | Key n | Pointer (_, n) -> n
257
258 let seq_of_test = function
259   | TestRun s | TestOutput (s, _) | TestOutputList (s, _)
260   | TestOutputListOfDevices (s, _)
261   | TestOutputInt (s, _) | TestOutputIntOp (s, _, _)
262   | TestOutputTrue s | TestOutputFalse s
263   | TestOutputLength (s, _) | TestOutputBuffer (s, _)
264   | TestOutputStruct (s, _)
265   | TestOutputFileMD5 (s, _)
266   | TestOutputDevice (s, _)
267   | TestOutputHashtable (s, _)
268   | TestLastFail s -> s
269
270 let c_quote str =
271   let str = replace_str str "\\" "\\\\" in
272   let str = replace_str str "\r" "\\r" in
273   let str = replace_str str "\n" "\\n" in
274   let str = replace_str str "\t" "\\t" in
275   let str = replace_str str "\000" "\\0" in
276   let str = replace_str str "\"" "\\\"" in
277   str
278
279 (* Used to memoize the result of pod2text. *)
280 let pod2text_memo_filename = "generator/.pod2text.data.version.2"
281 let pod2text_memo : ((int option * bool * bool * string * string), string list) Hashtbl.t =
282   try
283     let chan = open_in pod2text_memo_filename in
284     let v = input_value chan in
285     close_in chan;
286     v
287   with
288     _ -> Hashtbl.create 13
289 let pod2text_memo_updated () =
290   let chan = open_out pod2text_memo_filename in
291   output_value chan pod2text_memo;
292   close_out chan
293
294 (* Useful if you need the longdesc POD text as plain text.  Returns a
295  * list of lines.
296  *
297  * Because this is very slow (the slowest part of autogeneration),
298  * we memoize the results.
299  *)
300 let pod2text ?width ?(trim = true) ?(discard = true) name longdesc =
301   let key = width, trim, discard, name, longdesc in
302   try Hashtbl.find pod2text_memo key
303   with Not_found ->
304     let filename, chan = Filename.open_temp_file "gen" ".tmp" in
305     fprintf chan "=head1 %s\n\n%s\n" name longdesc;
306     close_out chan;
307     let cmd =
308       match width with
309       | Some width ->
310           sprintf "pod2text -w %d %s" width (Filename.quote filename)
311       | None ->
312           sprintf "pod2text %s" (Filename.quote filename) in
313     let chan = open_process_in cmd in
314     let lines = ref [] in
315     let rec loop i =
316       let line = input_line chan in
317       if i = 1 && discard then  (* discard the first line of output *)
318         loop (i+1)
319       else (
320         let line = if trim then triml line else line in
321         lines := line :: !lines;
322         loop (i+1)
323       ) in
324     let lines = try loop 1 with End_of_file -> List.rev !lines in
325     unlink filename;
326     (match close_process_in chan with
327      | WEXITED 0 -> ()
328      | WEXITED i ->
329          failwithf "pod2text: process exited with non-zero status (%d)" i
330      | WSIGNALED i | WSTOPPED i ->
331          failwithf "pod2text: process signalled or stopped by signal %d" i
332     );
333     Hashtbl.add pod2text_memo key lines;
334     pod2text_memo_updated ();
335     lines
336
337 (* Compare two actions (for sorting). *)
338 let action_compare (n1,_,_,_,_,_,_) (n2,_,_,_,_,_,_) = compare n1 n2
339
340 let chars c n =
341   let str = String.create n in
342   for i = 0 to n-1 do
343     String.unsafe_set str i c
344   done;
345   str
346
347 let spaces n = chars ' ' n