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   String.sub s 0 8 ^ "-"
  59   ^ String.sub s 8 4 ^ "-"
  60   ^ String.sub s 12 4 ^ "-"
  61   ^ String.sub s 16 4 ^ "-"
  62   ^ String.sub s 20 12
  63
  64 type rstructs_used_t = RStructOnly | RStructListOnly | RStructAndList
  65
  66 (* Returns a list of RStruct/RStructList structs that are returned
  67  * by any function.  Each element of returned list is a pair:
  68  *
  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)
  76  *)
  77 let rstructs_used_by functions =
  78   (* ||| is a "logical OR" for rstructs_used_t *)
  79   let (|||) a b =
  80     match a, b with
  81     | RStructAndList, _
  82     | _, RStructAndList -> RStructAndList
  83     | RStructOnly, RStructListOnly
  84     | RStructListOnly, RStructOnly -> RStructAndList
  85     | RStructOnly, RStructOnly -> RStructOnly
  86     | RStructListOnly, RStructListOnly -> RStructListOnly
  87   in
  88
  89   let h = Hashtbl.create 13 in
  90
  91   (* if elem->oldv exists, update entry using ||| operator,
  92    * else just add elem->newv to the hash
  93    *)
  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
  98   in
  99
 100   List.iter (
 101     fun (_, (ret, _, _), _, _, _, _, _) ->
 102       match ret with
 103       | RStruct (_, structname) -> update structname RStructOnly
 104       | RStructList (_, structname) -> update structname RStructListOnly
 105       | _ -> ()
 106   ) functions;
 107
 108   (* return key->values as a list of (key,value) *)
 109   Hashtbl.fold (fun key value xs -> (key, value) :: xs) h []
 110
 111 let failwithf fs = ksprintf failwith fs
 112
 113 let unique = let i = ref 0 in fun () -> incr i; !i
 114
 115 let replace_char s c1 c2 =
 116   let s2 = String.copy s in
 117   let r = ref false 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;
 121       r := true
 122     )
 123   done;
 124   if not !r then s else s2
 125
 126 let isspace c =
 127   c = ' '
 128   (* || c = '\f' *) || c = '\n' || c = '\r' || c = '\t' (* || c = '\v' *)
 129
 130 let triml ?(test = isspace) str =
 131   let i = ref 0 in
 132   let n = ref (String.length str) in
 133   while !n > 0 && test str.[!i]; do
 134     decr n;
 135     incr i
 136   done;
 137   if !i = 0 then str
 138   else String.sub str !i !n
 139
 140 let trimr ?(test = isspace) str =
 141   let n = ref (String.length str) in
 142   while !n > 0 && test str.[!n-1]; do
 143     decr n
 144   done;
 145   if !n = String.length str then str
 146   else String.sub str 0 !n
 147
 148 let trim ?(test = isspace) str =
 149   trimr ~test (triml ~test str)
 150
 151 let rec find s sub =
 152   let len = String.length s in
 153   let sublen = String.length sub in
 154   let rec loop i =
 155     if i <= len-sublen then (
 156       let rec loop2 j =
 157         if j < sublen then (
 158           if s.[i+j] = sub.[j] then loop2 (j+1)
 159           else -1
 160         ) else
 161           i (* found *)
 162       in
 163       let r = loop2 0 in
 164       if r = -1 then loop (i+1) else r
 165     ) else
 166       -1 (* not found *)
 167   in
 168   loop 0
 169
 170 let rec replace_str s s1 s2 =
 171   let len = String.length s in
 172   let sublen = String.length s1 in
 173   let i = find s s1 in
 174   if i = -1 then s
 175   else (
 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
 179   )
 180
 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
 185   if i = -1 then [str]
 186   else (
 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''
 190   )
 191
 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
 195   | 0 -> true
 196   | 1 -> false
 197   | i -> failwithf "%s: failed with error code %d" cmd i
 198
 199 let rec filter_map f = function
 200   | [] -> []
 201   | x :: xs ->
 202       match f x with
 203       | Some y -> y :: filter_map f xs
 204       | None -> filter_map f xs
 205
 206 let rec find_map f = function
 207   | [] -> raise Not_found
 208   | x :: xs ->
 209       match f x with
 210       | Some y -> y
 211       | None -> find_map f xs
 212
 213 let iteri f xs =
 214   let rec loop i = function
 215     | [] -> ()
 216     | x :: xs -> f i x; loop (i+1) xs
 217   in
 218   loop 0 xs
 219
 220 let mapi f xs =
 221   let rec loop i = function
 222     | [] -> []
 223     | x :: xs -> let r = f i x in r :: loop (i+1) xs
 224   in
 225   loop 0 xs
 226
 227 let count_chars c str =
 228   let count = ref 0 in
 229   for i = 0 to String.length str - 1 do
 230     if c = String.unsafe_get str i then incr count
 231   done;
 232   !count
 233
 234 let explode str =
 235   let r = ref [] in
 236   for i = 0 to String.length str - 1 do
 237     let c = String.unsafe_get str i in
 238     r := c :: !r;
 239   done;
 240   List.rev !r
 241
 242 let map_chars f str =
 243   List.map f (explode str)
 244
 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
 249
 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
 260
 261 let c_quote str =
 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
 268   str
 269
 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 =
 273   try
 274     let chan = open_in pod2text_memo_filename in
 275     let v = input_value chan in
 276     close_in chan;
 277     v
 278   with
 279     _ -> Hashtbl.create 13
 280 let pod2text_memo_updated () =
 281   let chan = open_out pod2text_memo_filename in
 282   output_value chan pod2text_memo;
 283   close_out chan
 284
 285 (* Useful if you need the longdesc POD text as plain text.  Returns a
 286  * list of lines.
 287  *
 288  * Because this is very slow (the slowest part of autogeneration),
 289  * we memoize the results.
 290  *)
 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
 294   with Not_found ->
 295     let filename, chan = Filename.open_temp_file "gen" ".tmp" in
 296     fprintf chan "=head1 %s\n\n%s\n" name longdesc;
 297     close_out chan;
 298     let cmd =
 299       match width with
 300       | Some width ->
 301           sprintf "pod2text -w %d %s" width (Filename.quote filename)
 302       | None ->
 303           sprintf "pod2text %s" (Filename.quote filename) in
 304     let chan = open_process_in cmd in
 305     let lines = ref [] in
 306     let rec loop i =
 307       let line = input_line chan in
 308       if i = 1 && discard then  (* discard the first line of output *)
 309         loop (i+1)
 310       else (
 311         let line = if trim then triml line else line in
 312         lines := line :: !lines;
 313         loop (i+1)
 314       ) in
 315     let lines = try loop 1 with End_of_file -> List.rev !lines in
 316     unlink filename;
 317     (match close_process_in chan with
 318      | WEXITED 0 -> ()
 319      | WEXITED i ->
 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
 323     );
 324     Hashtbl.add pod2text_memo key lines;
 325     pod2text_memo_updated ();
 326     lines
 327
 328 (* Compare two actions (for sorting). *)
 329 let action_compare (n1,_,_,_,_,_,_) (n2,_,_,_,_,_,_) = compare n1 n2
 330
 331 let chars c n =
 332   let str = String.create n in
 333   for i = 0 to n-1 do
 334     String.unsafe_set str i c
 335   done;
 336   str
 337
 338 let spaces n = chars ' ' n