generator/generator_utils.ml

   1 (* libguestfs
   2  * Copyright (C) 2009-2010 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 (* Generate a uuidgen-compatible UUID (used in tests).  However to
  32  * avoid having the UUID change every time we rebuild the tests,
  33  * generate it as a function of the contents of the
  34  * generator_actions.ml file.
  35  *
  36  * Originally I thought uuidgen was using RFC 4122, but it doesn't
  37  * appear to.
  38  *
  39  * Note that the format must be 01234567-0123-0123-0123-0123456789ab
  40  *)
  41 let uuidgen () =
  42   let s = Digest.to_hex (Digest.file "generator/generator_actions.ml") in
  43   String.sub s 0 8 ^ "-"
  44   ^ String.sub s 8 4 ^ "-"
  45   ^ String.sub s 12 4 ^ "-"
  46   ^ String.sub s 16 4 ^ "-"
  47   ^ String.sub s 20 12
  48
  49 type rstructs_used_t = RStructOnly | RStructListOnly | RStructAndList
  50
  51 (* Returns a list of RStruct/RStructList structs that are returned
  52  * by any function.  Each element of returned list is a pair:
  53  *
  54  * (structname, RStructOnly)
  55  *    == there exists function which returns RStruct (_, structname)
  56  * (structname, RStructListOnly)
  57  *    == there exists function which returns RStructList (_, structname)
  58  * (structname, RStructAndList)
  59  *    == there are functions returning both RStruct (_, structname)
  60  *                                      and RStructList (_, structname)
  61  *)
  62 let rstructs_used_by functions =
  63   (* ||| is a "logical OR" for rstructs_used_t *)
  64   let (|||) a b =
  65     match a, b with
  66     | RStructAndList, _
  67     | _, RStructAndList -> RStructAndList
  68     | RStructOnly, RStructListOnly
  69     | RStructListOnly, RStructOnly -> RStructAndList
  70     | RStructOnly, RStructOnly -> RStructOnly
  71     | RStructListOnly, RStructListOnly -> RStructListOnly
  72   in
  73
  74   let h = Hashtbl.create 13 in
  75
  76   (* if elem->oldv exists, update entry using ||| operator,
  77    * else just add elem->newv to the hash
  78    *)
  79   let update elem newv =
  80     try  let oldv = Hashtbl.find h elem in
  81          Hashtbl.replace h elem (newv ||| oldv)
  82     with Not_found -> Hashtbl.add h elem newv
  83   in
  84
  85   List.iter (
  86     fun (_, (ret, _, _), _, _, _, _, _) ->
  87       match ret with
  88       | RStruct (_, structname) -> update structname RStructOnly
  89       | RStructList (_, structname) -> update structname RStructListOnly
  90       | _ -> ()
  91   ) functions;
  92
  93   (* return key->values as a list of (key,value) *)
  94   Hashtbl.fold (fun key value xs -> (key, value) :: xs) h []
  95
  96 let failwithf fs = ksprintf failwith fs
  97
  98 let unique = let i = ref 0 in fun () -> incr i; !i
  99
 100 let replace_char s c1 c2 =
 101   let s2 = String.copy s in
 102   let r = ref false in
 103   for i = 0 to String.length s2 - 1 do
 104     if String.unsafe_get s2 i = c1 then (
 105       String.unsafe_set s2 i c2;
 106       r := true
 107     )
 108   done;
 109   if not !r then s else s2
 110
 111 let isspace c =
 112   c = ' '
 113   (* || c = '\f' *) || c = '\n' || c = '\r' || c = '\t' (* || c = '\v' *)
 114
 115 let triml ?(test = isspace) str =
 116   let i = ref 0 in
 117   let n = ref (String.length str) in
 118   while !n > 0 && test str.[!i]; do
 119     decr n;
 120     incr i
 121   done;
 122   if !i = 0 then str
 123   else String.sub str !i !n
 124
 125 let trimr ?(test = isspace) str =
 126   let n = ref (String.length str) in
 127   while !n > 0 && test str.[!n-1]; do
 128     decr n
 129   done;
 130   if !n = String.length str then str
 131   else String.sub str 0 !n
 132
 133 let trim ?(test = isspace) str =
 134   trimr ~test (triml ~test str)
 135
 136 let rec find s sub =
 137   let len = String.length s in
 138   let sublen = String.length sub in
 139   let rec loop i =
 140     if i <= len-sublen then (
 141       let rec loop2 j =
 142         if j < sublen then (
 143           if s.[i+j] = sub.[j] then loop2 (j+1)
 144           else -1
 145         ) else
 146           i (* found *)
 147       in
 148       let r = loop2 0 in
 149       if r = -1 then loop (i+1) else r
 150     ) else
 151       -1 (* not found *)
 152   in
 153   loop 0
 154
 155 let rec replace_str s s1 s2 =
 156   let len = String.length s in
 157   let sublen = String.length s1 in
 158   let i = find s s1 in
 159   if i = -1 then s
 160   else (
 161     let s' = String.sub s 0 i in
 162     let s'' = String.sub s (i+sublen) (len-i-sublen) in
 163     s' ^ s2 ^ replace_str s'' s1 s2
 164   )
 165
 166 let rec string_split sep str =
 167   let len = String.length str in
 168   let seplen = String.length sep in
 169   let i = find str sep in
 170   if i = -1 then [str]
 171   else (
 172     let s' = String.sub str 0 i in
 173     let s'' = String.sub str (i+seplen) (len-i-seplen) in
 174     s' :: string_split sep s''
 175   )
 176
 177 let files_equal n1 n2 =
 178   let cmd = sprintf "cmp -s %s %s" (Filename.quote n1) (Filename.quote n2) in
 179   match Sys.command cmd with
 180   | 0 -> true
 181   | 1 -> false
 182   | i -> failwithf "%s: failed with error code %d" cmd i
 183
 184 let rec filter_map f = function
 185   | [] -> []
 186   | x :: xs ->
 187       match f x with
 188       | Some y -> y :: filter_map f xs
 189       | None -> filter_map f xs
 190
 191 let rec find_map f = function
 192   | [] -> raise Not_found
 193   | x :: xs ->
 194       match f x with
 195       | Some y -> y
 196       | None -> find_map f xs
 197
 198 let iteri f xs =
 199   let rec loop i = function
 200     | [] -> ()
 201     | x :: xs -> f i x; loop (i+1) xs
 202   in
 203   loop 0 xs
 204
 205 let mapi f xs =
 206   let rec loop i = function
 207     | [] -> []
 208     | x :: xs -> let r = f i x in r :: loop (i+1) xs
 209   in
 210   loop 0 xs
 211
 212 let count_chars c str =
 213   let count = ref 0 in
 214   for i = 0 to String.length str - 1 do
 215     if c = String.unsafe_get str i then incr count
 216   done;
 217   !count
 218
 219 let explode str =
 220   let r = ref [] in
 221   for i = 0 to String.length str - 1 do
 222     let c = String.unsafe_get str i in
 223     r := c :: !r;
 224   done;
 225   List.rev !r
 226
 227 let map_chars f str =
 228   List.map f (explode str)
 229
 230 let name_of_argt = function
 231   | Pathname n | Device n | Dev_or_Path n | String n | OptString n
 232   | StringList n | DeviceList n | Bool n | Int n | Int64 n
 233   | FileIn n | FileOut n | BufferIn n | Key n -> n
 234
 235 let seq_of_test = function
 236   | TestRun s | TestOutput (s, _) | TestOutputList (s, _)
 237   | TestOutputListOfDevices (s, _)
 238   | TestOutputInt (s, _) | TestOutputIntOp (s, _, _)
 239   | TestOutputTrue s | TestOutputFalse s
 240   | TestOutputLength (s, _) | TestOutputBuffer (s, _)
 241   | TestOutputStruct (s, _)
 242   | TestOutputFileMD5 (s, _)
 243   | TestOutputDevice (s, _)
 244   | TestLastFail s -> s
 245
 246 let c_quote str =
 247   let str = replace_str str "\r" "\\r" in
 248   let str = replace_str str "\n" "\\n" in
 249   let str = replace_str str "\t" "\\t" in
 250   let str = replace_str str "\000" "\\0" in
 251   str
 252
 253 (* Used to memoize the result of pod2text. *)
 254 let pod2text_memo_filename = "generator/.pod2text.data"
 255 let pod2text_memo : ((int * string * string), string list) Hashtbl.t =
 256   try
 257     let chan = open_in pod2text_memo_filename in
 258     let v = input_value chan in
 259     close_in chan;
 260     v
 261   with
 262     _ -> Hashtbl.create 13
 263 let pod2text_memo_updated () =
 264   let chan = open_out pod2text_memo_filename in
 265   output_value chan pod2text_memo;
 266   close_out chan
 267
 268 (* Useful if you need the longdesc POD text as plain text.  Returns a
 269  * list of lines.
 270  *
 271  * Because this is very slow (the slowest part of autogeneration),
 272  * we memoize the results.
 273  *)
 274 let pod2text ~width name longdesc =
 275   let key = width, name, longdesc in
 276   try Hashtbl.find pod2text_memo key
 277   with Not_found ->
 278     let filename, chan = Filename.open_temp_file "gen" ".tmp" in
 279     fprintf chan "=head1 %s\n\n%s\n" name longdesc;
 280     close_out chan;
 281     let cmd = sprintf "pod2text -w %d %s" width (Filename.quote filename) in
 282     let chan = open_process_in cmd in
 283     let lines = ref [] in
 284     let rec loop i =
 285       let line = input_line chan in
 286       if i = 1 then             (* discard the first line of output *)
 287         loop (i+1)
 288       else (
 289         let line = triml line in
 290         lines := line :: !lines;
 291         loop (i+1)
 292       ) in
 293     let lines = try loop 1 with End_of_file -> List.rev !lines in
 294     unlink filename;
 295     (match close_process_in chan with
 296      | WEXITED 0 -> ()
 297      | WEXITED i ->
 298          failwithf "pod2text: process exited with non-zero status (%d)" i
 299      | WSIGNALED i | WSTOPPED i ->
 300          failwithf "pod2text: process signalled or stopped by signal %d" i
 301     );
 302     Hashtbl.add pod2text_memo key lines;
 303     pod2text_memo_updated ();
 304     lines
 305
 306 (* Compare two actions (for sorting). *)
 307 let action_compare (n1,_,_,_,_,_,_) (n2,_,_,_,_,_,_) = compare n1 n2