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