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