2 * Copyright (C) 2009-2011 Red Hat Inc.
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.
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.
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
19 (* Please read generator/README first. *)
22 * Note we don't want to use any external OCaml libraries which
23 * makes this a bit harder than it should be.
31 let errcode_of_ret = function
32 | RConstOptString _ ->
34 | RErr | RInt _ | RBool _ | RInt64 _ ->
37 | RString _ | RBufferOut _
38 | RStringList _ | RHashtable _
39 | RStruct _ | RStructList _ ->
42 let string_of_errcode = function
43 | `ErrorIsMinusOne -> "-1"
44 | `ErrorIsNULL -> "NULL"
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.
51 * Originally I thought uuidgen was using RFC 4122, but it doesn't
54 * Note that the format must be 01234567-0123-0123-0123-0123456789ab
57 let s = Digest.to_hex (Digest.file "generator/generator_actions.ml") in
58 String.sub s 0 8 ^ "-"
59 ^ String.sub s 8 4 ^ "-"
60 ^ String.sub s 12 4 ^ "-"
61 ^ String.sub s 16 4 ^ "-"
64 type rstructs_used_t = RStructOnly | RStructListOnly | RStructAndList
66 (* Returns a list of RStruct/RStructList structs that are returned
67 * by any function. Each element of returned list is a pair:
69 * (structname, RStructOnly)
70 * == there exists function which returns RStruct (_, structname)
71 * (structname, RStructListOnly)
72 * == there exists function which returns RStructList (_, structname)
73 * (structname, RStructAndList)
74 * == there are functions returning both RStruct (_, structname)
75 * and RStructList (_, structname)
77 let rstructs_used_by functions =
78 (* ||| is a "logical OR" for rstructs_used_t *)
82 | _, RStructAndList -> RStructAndList
83 | RStructOnly, RStructListOnly
84 | RStructListOnly, RStructOnly -> RStructAndList
85 | RStructOnly, RStructOnly -> RStructOnly
86 | RStructListOnly, RStructListOnly -> RStructListOnly
89 let h = Hashtbl.create 13 in
91 (* if elem->oldv exists, update entry using ||| operator,
92 * else just add elem->newv to the hash
94 let update elem newv =
95 try let oldv = Hashtbl.find h elem in
96 Hashtbl.replace h elem (newv ||| oldv)
97 with Not_found -> Hashtbl.add h elem newv
101 fun (_, (ret, _, _), _, _, _, _, _) ->
103 | RStruct (_, structname) -> update structname RStructOnly
104 | RStructList (_, structname) -> update structname RStructListOnly
108 (* return key->values as a list of (key,value) *)
109 Hashtbl.fold (fun key value xs -> (key, value) :: xs) h []
111 let failwithf fs = ksprintf failwith fs
113 let unique = let i = ref 0 in fun () -> incr i; !i
115 let replace_char s c1 c2 =
116 let s2 = String.copy s in
118 for i = 0 to String.length s2 - 1 do
119 if String.unsafe_get s2 i = c1 then (
120 String.unsafe_set s2 i c2;
124 if not !r then s else s2
128 (* || c = '\f' *) || c = '\n' || c = '\r' || c = '\t' (* || c = '\v' *)
130 let triml ?(test = isspace) str =
132 let n = ref (String.length str) in
133 while !n > 0 && test str.[!i]; do
138 else String.sub str !i !n
140 let trimr ?(test = isspace) str =
141 let n = ref (String.length str) in
142 while !n > 0 && test str.[!n-1]; do
145 if !n = String.length str then str
146 else String.sub str 0 !n
148 let trim ?(test = isspace) str =
149 trimr ~test (triml ~test str)
152 let len = String.length s in
153 let sublen = String.length sub in
155 if i <= len-sublen then (
158 if s.[i+j] = sub.[j] then loop2 (j+1)
164 if r = -1 then loop (i+1) else r
170 let rec replace_str s s1 s2 =
171 let len = String.length s in
172 let sublen = String.length s1 in
176 let s' = String.sub s 0 i in
177 let s'' = String.sub s (i+sublen) (len-i-sublen) in
178 s' ^ s2 ^ replace_str s'' s1 s2
181 let rec string_split sep str =
182 let len = String.length str in
183 let seplen = String.length sep in
184 let i = find str sep in
187 let s' = String.sub str 0 i in
188 let s'' = String.sub str (i+seplen) (len-i-seplen) in
189 s' :: string_split sep s''
192 let files_equal n1 n2 =
193 let cmd = sprintf "cmp -s %s %s" (Filename.quote n1) (Filename.quote n2) in
194 match Sys.command cmd with
197 | i -> failwithf "%s: failed with error code %d" cmd i
199 let rec filter_map f = function
203 | Some y -> y :: filter_map f xs
204 | None -> filter_map f xs
206 let rec find_map f = function
207 | [] -> raise Not_found
211 | None -> find_map f xs
214 let rec loop i = function
216 | x :: xs -> f i x; loop (i+1) xs
221 let rec loop i = function
223 | x :: xs -> let r = f i x in r :: loop (i+1) xs
227 let count_chars c str =
229 for i = 0 to String.length str - 1 do
230 if c = String.unsafe_get str i then incr count
236 for i = 0 to String.length str - 1 do
237 let c = String.unsafe_get str i in
242 let map_chars f str =
243 List.map f (explode str)
245 let name_of_argt = function
246 | Pathname n | Device n | Dev_or_Path n | String n | OptString n
247 | StringList n | DeviceList n | Bool n | Int n | Int64 n
248 | FileIn n | FileOut n | BufferIn n | Key n | Pointer (_, n) -> n
250 let seq_of_test = function
251 | TestRun s | TestOutput (s, _) | TestOutputList (s, _)
252 | TestOutputListOfDevices (s, _)
253 | TestOutputInt (s, _) | TestOutputIntOp (s, _, _)
254 | TestOutputTrue s | TestOutputFalse s
255 | TestOutputLength (s, _) | TestOutputBuffer (s, _)
256 | TestOutputStruct (s, _)
257 | TestOutputFileMD5 (s, _)
258 | TestOutputDevice (s, _)
259 | TestLastFail s -> s
262 let str = replace_str str "\\" "\\\\" in
263 let str = replace_str str "\r" "\\r" in
264 let str = replace_str str "\n" "\\n" in
265 let str = replace_str str "\t" "\\t" in
266 let str = replace_str str "\000" "\\0" in
267 let str = replace_str str "\"" "\\\"" in
270 (* Used to memoize the result of pod2text. *)
271 let pod2text_memo_filename = "generator/.pod2text.data.version.2"
272 let pod2text_memo : ((int option * bool * bool * string * string), string list) Hashtbl.t =
274 let chan = open_in pod2text_memo_filename in
275 let v = input_value chan in
279 _ -> Hashtbl.create 13
280 let pod2text_memo_updated () =
281 let chan = open_out pod2text_memo_filename in
282 output_value chan pod2text_memo;
285 (* Useful if you need the longdesc POD text as plain text. Returns a
288 * Because this is very slow (the slowest part of autogeneration),
289 * we memoize the results.
291 let pod2text ?width ?(trim = true) ?(discard = true) name longdesc =
292 let key = width, trim, discard, name, longdesc in
293 try Hashtbl.find pod2text_memo key
295 let filename, chan = Filename.open_temp_file "gen" ".tmp" in
296 fprintf chan "=head1 %s\n\n%s\n" name longdesc;
301 sprintf "pod2text -w %d %s" width (Filename.quote filename)
303 sprintf "pod2text %s" (Filename.quote filename) in
304 let chan = open_process_in cmd in
305 let lines = ref [] in
307 let line = input_line chan in
308 if i = 1 && discard then (* discard the first line of output *)
311 let line = if trim then triml line else line in
312 lines := line :: !lines;
315 let lines = try loop 1 with End_of_file -> List.rev !lines in
317 (match close_process_in chan with
320 failwithf "pod2text: process exited with non-zero status (%d)" i
321 | WSIGNALED i | WSTOPPED i ->
322 failwithf "pod2text: process signalled or stopped by signal %d" i
324 Hashtbl.add pod2text_memo key lines;
325 pod2text_memo_updated ();
328 (* Compare two actions (for sorting). *)
329 let action_compare (n1,_,_,_,_,_,_) (n2,_,_,_,_,_,_) = compare n1 n2
332 let str = String.create n in
334 String.unsafe_set str i c
338 let spaces n = chars ' ' n