ruby: Add unit test for new RLenValue type
[hivex.git] / generator / generator.ml
1 #!/usr/bin/env ocaml
2 (* hivex
3  * Copyright (C) 2009-2011 Red Hat Inc.
4  *
5  * This program is free software; you can redistribute it and/or modify
6  * it under the terms of the GNU General Public License as published by
7  * the Free Software Foundation; either version 2 of the License, or
8  * (at your option) any later version.
9  *
10  * This program is distributed in the hope that it will be useful,
11  * but WITHOUT ANY WARRANTY; without even the implied warranty of
12  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13  * GNU General Public License for more details.
14  *
15  * You should have received a copy of the GNU General Public License
16  * along with this program; if not, write to the Free Software
17  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
18  *)
19
20 (* This script generates language bindings and some documentation for
21  * hivex.
22  *
23  * After editing this file, run it (./generator/generator.ml) to
24  * regenerate all the output files.  'make' will rerun this
25  * automatically when necessary.  Note that if you are using a separate
26  * build directory you must run generator.ml from the _source_
27  * directory.
28  *
29  * IMPORTANT: This script should NOT print any warnings.  If it prints
30  * warnings, you should treat them as errors.
31  *
32  * OCaml tips: (1) In emacs, install tuareg-mode to display and format
33  * OCaml code correctly.  'vim' comes with a good OCaml editing mode by
34  * default.  (2) Read the resources at http://ocaml-tutorial.org/
35  *)
36
37 #load "unix.cma";;
38 #load "str.cma";;
39
40 open Unix
41 open Printf
42
43 type style = ret * args
44 and ret =
45   | RErr                                (* 0 = ok, -1 = error *)
46   | RErrDispose                         (* Disposes handle, see hivex_close. *)
47   | RHive                               (* Returns a hive_h or NULL. *)
48   | RSize                               (* Returns size_t or 0. *)
49   | RNode                               (* Returns hive_node_h or 0. *)
50   | RNodeNotFound                       (* See hivex_node_get_child. *)
51   | RNodeList                           (* Returns hive_node_h* or NULL. *)
52   | RValue                              (* Returns hive_value_h or 0. *)
53   | RValueList                          (* Returns hive_value_h* or NULL. *)
54   | RLenValue                           (* Returns offset and length of value. *)
55   | RString                             (* Returns char* or NULL. *)
56   | RStringList                         (* Returns char** or NULL. *)
57   | RLenType                            (* See hivex_value_type. *)
58   | RLenTypeVal                         (* See hivex_value_value. *)
59   | RInt32                              (* Returns int32. *)
60   | RInt64                              (* Returns int64. *)
61
62 and args = argt list                    (* List of parameters. *)
63
64 and argt =                              (* Note, cannot be NULL/0 unless it
65                                            says so explicitly below. *)
66   | AHive                               (* hive_h* *)
67   | ANode of string                     (* hive_node_h *)
68   | AValue of string                    (* hive_value_h *)
69   | AString of string                   (* char* *)
70   | AStringNullable of string           (* char* (can be NULL) *)
71   | AOpenFlags                          (* HIVEX_OPEN_* flags list. *)
72   | AUnusedFlags                        (* Flags arg that is always 0 *)
73   | ASetValues                          (* See hivex_node_set_values. *)
74   | ASetValue                           (* See hivex_node_set_value. *)
75
76 (* Hive types, from:
77  * https://secure.wikimedia.org/wikipedia/en/wiki/Windows_Registry#Keys_and_values
78  *
79  * It's unfortunate that in our original C binding we strayed away from
80  * the names that Windows uses (eg. REG_SZ for strings).  We include
81  * both our names and the Windows names.
82  *)
83 let hive_types = [
84   0, "none", "NONE",
85     "Just a key without a value";
86   1, "string", "SZ",
87     "A Windows string (encoding is unknown, but often UTF16-LE)";
88   2, "expand_string", "EXPAND_SZ",
89     "A Windows string that contains %env% (environment variable expansion)";
90   3, "binary", "BINARY",
91     "A blob of binary";
92   4, "dword", "DWORD",
93     "DWORD (32 bit integer), little endian";
94   5, "dword_be", "DWORD_BIG_ENDIAN",
95     "DWORD (32 bit integer), big endian";
96   6, "link", "LINK",
97     "Symbolic link to another part of the registry tree";
98   7, "multiple_strings", "MULTI_SZ",
99     "Multiple Windows strings.  See http://blogs.msdn.com/oldnewthing/archive/2009/10/08/9904646.aspx";
100   8, "resource_list", "RESOURCE_LIST",
101     "Resource list";
102   9, "full_resource_description", "FULL_RESOURCE_DESCRIPTOR",
103     "Resource descriptor";
104   10, "resource_requirements_list", "RESOURCE_REQUIREMENTS_LIST",
105     "Resouce requirements list";
106   11, "qword", "QWORD",
107     "QWORD (64 bit integer), unspecified endianness but usually little endian"
108 ]
109 let max_hive_type = 11
110
111 (* Open flags (bitmask passed to AOpenFlags) *)
112 let open_flags = [
113   1, "VERBOSE", "Verbose messages";
114   2, "DEBUG", "Debug messages";
115   4, "WRITE", "Enable writes to the hive";
116 ]
117
118 (* The API calls. *)
119 let functions = [
120   "open", (RHive, [AString "filename"; AOpenFlags]),
121     "open a hive file",
122     "\
123 Opens the hive named C<filename> for reading.
124
125 Flags is an ORed list of the open flags (or C<0> if you don't
126 want to pass any flags).  These flags are defined:
127
128 =over 4
129
130 =item HIVEX_OPEN_VERBOSE
131
132 Verbose messages.
133
134 =item HIVEX_OPEN_DEBUG
135
136 Very verbose messages, suitable for debugging problems in the library
137 itself.
138
139 This is also selected if the C<HIVEX_DEBUG> environment variable
140 is set to 1.
141
142 =item HIVEX_OPEN_WRITE
143
144 Open the hive for writing.  If omitted, the hive is read-only.
145
146 See L<hivex(3)/WRITING TO HIVE FILES>.
147
148 =back";
149
150   "close", (RErrDispose, [AHive]),
151     "close a hive handle",
152     "\
153 Close a hive handle and free all associated resources.
154
155 Note that any uncommitted writes are I<not> committed by this call,
156 but instead are lost.  See L<hivex(3)/WRITING TO HIVE FILES>.";
157
158   "root", (RNode, [AHive]),
159     "return the root node of the hive",
160     "\
161 Return root node of the hive.  All valid hives must contain a root node.";
162
163   "last_modified", (RInt64, [AHive]),
164     "return the modification time from the header of the hive",
165     "\
166 Return the modification time from the header of the hive.
167
168 The returned value is a Windows filetime.
169 To convert this to a Unix C<time_t> see:
170 L<http://stackoverflow.com/questions/6161776/convert-windows-filetime-to-second-in-unix-linux/6161842#6161842>";
171
172   "node_name", (RString, [AHive; ANode "node"]),
173     "return the name of the node",
174     "\
175 Return the name of the node.
176
177 Note that the name of the root node is a dummy, such as
178 C<$$$PROTO.HIV> (other names are possible: it seems to depend on the
179 tool or program that created the hive in the first place).  You can
180 only know the \"real\" name of the root node by knowing which registry
181 file this hive originally comes from, which is knowledge that is
182 outside the scope of this library.";
183
184   "node_timestamp", (RInt64, [AHive; ANode "node"]),
185     "return the modification time of the node",
186     "\
187 Return the modification time of the node.
188
189 The returned value is a Windows filetime.
190 To convert this to a Unix C<time_t> see:
191 L<http://stackoverflow.com/questions/6161776/convert-windows-filetime-to-second-in-unix-linux/6161842#6161842>";
192
193   "node_children", (RNodeList, [AHive; ANode "node"]),
194     "return children of node",
195     "\
196 Return an array of nodes which are the subkeys
197 (children) of C<node>.";
198
199   "node_get_child", (RNodeNotFound, [AHive; ANode "node"; AString "name"]),
200     "return named child of node",
201     "\
202 Return the child of node with the name C<name>, if it exists.
203
204 The name is matched case insensitively.";
205
206   "node_parent", (RNode, [AHive; ANode "node"]),
207     "return the parent of node",
208     "\
209 Return the parent of C<node>.
210
211 The parent pointer of the root node in registry files that we
212 have examined seems to be invalid, and so this function will
213 return an error if called on the root node.";
214
215   "node_values", (RValueList, [AHive; ANode "node"]),
216     "return (key, value) pairs attached to a node",
217     "\
218 Return the array of (key, value) pairs attached to this node.";
219
220   "node_get_value", (RValue, [AHive; ANode "node"; AString "key"]),
221     "return named key at node",
222     "\
223 Return the value attached to this node which has the name C<key>,
224 if it exists.
225
226 The key name is matched case insensitively.
227
228 Note that to get the default key, you should pass the empty
229 string C<\"\"> here.  The default key is often written C<\"@\">, but
230 inside hives that has no meaning and won't give you the
231 default key.";
232
233   "value_key_len", (RSize, [AHive; AValue "val"]),
234     "return the length of a value's key",
235     "\
236 Return the length of the key (name) of a (key, value) pair.  The
237 length can legitimately be 0, so errno is the necesary mechanism
238 to check for errors.
239
240 In the context of Windows Registries, a zero-length name means
241 that this value is the default key for this node in the tree.
242 This is usually written as C<\"@\">.";
243
244   "value_key", (RString, [AHive; AValue "val"]),
245     "return the key of a (key, value) pair",
246     "\
247 Return the key (name) of a (key, value) pair.  The name
248 is reencoded as UTF-8 and returned as a string.
249
250 The string should be freed by the caller when it is no longer needed.
251
252 Note that this function can return a zero-length string.  In the
253 context of Windows Registries, this means that this value is the
254 default key for this node in the tree.  This is usually written
255 as C<\"@\">.";
256
257   "value_type", (RLenType, [AHive; AValue "val"]),
258     "return data length and data type of a value",
259     "\
260 Return the data length and data type of the value in this (key, value)
261 pair.  See also C<hivex_value_value> which returns all this
262 information, and the value itself.  Also, C<hivex_value_*> functions
263 below which can be used to return the value in a more useful form when
264 you know the type in advance.";
265
266   "node_struct_length", (RSize, [AHive; ANode "node"]),
267     "return the length of a node",
268     "\
269 Return the length of the node data structure.";
270
271   "value_struct_length", (RSize, [AHive; AValue "val"]),
272     "return the length of a value data structure",
273     "\
274 Return the length of the value data structure.";
275
276   "value_data_cell_offset", (RLenValue, [AHive; AValue "val"]),
277     "return the offset and length of a value data cell",
278     "\
279 Return the offset and length of the value's data cell.
280
281 The data cell is a registry structure that contains the length
282 (a 4 byte, little endian integer) followed by the data.
283
284 If the length of the value is less than or equal to 4 bytes
285 then the offset and length returned by this function is zero
286 as the data is inlined in the value.
287
288 Returns 0 and sets errno on error.";
289
290   "value_value", (RLenTypeVal, [AHive; AValue "val"]),
291     "return data length, data type and data of a value",
292     "\
293 Return the value of this (key, value) pair.  The value should
294 be interpreted according to its type (see C<hive_type>).";
295
296   "value_string", (RString, [AHive; AValue "val"]),
297     "return value as a string",
298     "\
299 If this value is a string, return the string reencoded as UTF-8
300 (as a C string).  This only works for values which have type
301 C<hive_t_string>, C<hive_t_expand_string> or C<hive_t_link>.";
302
303   "value_multiple_strings", (RStringList, [AHive; AValue "val"]),
304     "return value as multiple strings",
305     "\
306 If this value is a multiple-string, return the strings reencoded
307 as UTF-8 (in C, as a NULL-terminated array of C strings, in other
308 language bindings, as a list of strings).  This only
309 works for values which have type C<hive_t_multiple_strings>.";
310
311   "value_dword", (RInt32, [AHive; AValue "val"]),
312     "return value as a DWORD",
313     "\
314 If this value is a DWORD (Windows int32), return it.  This only works
315 for values which have type C<hive_t_dword> or C<hive_t_dword_be>.";
316
317   "value_qword", (RInt64, [AHive; AValue "val"]),
318     "return value as a QWORD",
319     "\
320 If this value is a QWORD (Windows int64), return it.  This only
321 works for values which have type C<hive_t_qword>.";
322
323   "commit", (RErr, [AHive; AStringNullable "filename"; AUnusedFlags]),
324     "commit (write) changes to file",
325     "\
326 Commit (write) any changes which have been made.
327
328 C<filename> is the new file to write.  If C<filename> is null/undefined
329 then we overwrite the original file (ie. the file name that was passed to
330 C<hivex_open>).
331
332 Note this does not close the hive handle.  You can perform further
333 operations on the hive after committing, including making more
334 modifications.  If you no longer wish to use the hive, then you
335 should close the handle after committing.";
336
337   "node_add_child", (RNode, [AHive; ANode "parent"; AString "name"]),
338     "add child node",
339     "\
340 Add a new child node named C<name> to the existing node C<parent>.
341 The new child initially has no subnodes and contains no keys or
342 values.  The sk-record (security descriptor) is inherited from
343 the parent.
344
345 The parent must not have an existing child called C<name>, so if you
346 want to overwrite an existing child, call C<hivex_node_delete_child>
347 first.";
348
349   "node_delete_child", (RErr, [AHive; ANode "node"]),
350     "delete child node",
351     "\
352 Delete the node C<node>.  All values at the node and all subnodes are
353 deleted (recursively).  The C<node> handle and the handles of all
354 subnodes become invalid.  You cannot delete the root node.";
355
356   "node_set_values", (RErr, [AHive; ANode "node"; ASetValues; AUnusedFlags]),
357     "set (key, value) pairs at a node",
358     "\
359 This call can be used to set all the (key, value) pairs
360 stored in C<node>.
361
362 C<node> is the node to modify.";
363
364   "node_set_value", (RErr, [AHive; ANode "node"; ASetValue; AUnusedFlags]),
365     "set a single (key, value) pair at a given node",
366     "\
367 This call can be used to replace a single C<(key, value)> pair
368 stored in C<node>.  If the key does not already exist, then a
369 new key is added.  Key matching is case insensitive.
370
371 C<node> is the node to modify.";
372 ]
373
374 (* Useful functions.
375  * Note we don't want to use any external OCaml libraries which
376  * makes this a bit harder than it should be.
377  *)
378 module StringMap = Map.Make (String)
379
380 let failwithf fs = ksprintf failwith fs
381
382 let unique = let i = ref 0 in fun () -> incr i; !i
383
384 let replace_char s c1 c2 =
385   let s2 = String.copy s in
386   let r = ref false in
387   for i = 0 to String.length s2 - 1 do
388     if String.unsafe_get s2 i = c1 then (
389       String.unsafe_set s2 i c2;
390       r := true
391     )
392   done;
393   if not !r then s else s2
394
395 let isspace c =
396   c = ' '
397   (* || c = '\f' *) || c = '\n' || c = '\r' || c = '\t' (* || c = '\v' *)
398
399 let triml ?(test = isspace) str =
400   let i = ref 0 in
401   let n = ref (String.length str) in
402   while !n > 0 && test str.[!i]; do
403     decr n;
404     incr i
405   done;
406   if !i = 0 then str
407   else String.sub str !i !n
408
409 let trimr ?(test = isspace) str =
410   let n = ref (String.length str) in
411   while !n > 0 && test str.[!n-1]; do
412     decr n
413   done;
414   if !n = String.length str then str
415   else String.sub str 0 !n
416
417 let trim ?(test = isspace) str =
418   trimr ~test (triml ~test str)
419
420 (* Used to memoize the result of pod2text. *)
421 let pod2text_memo_filename = "generator/.pod2text.data.version.2"
422 let pod2text_memo : ((int option * bool * bool * string * string), string list) Hashtbl.t =
423   try
424     let chan = open_in pod2text_memo_filename in
425     let v = input_value chan in
426     close_in chan;
427     v
428   with
429     _ -> Hashtbl.create 13
430 let pod2text_memo_updated () =
431   let chan = open_out pod2text_memo_filename in
432   output_value chan pod2text_memo;
433   close_out chan
434
435 (* Useful if you need the longdesc POD text as plain text.  Returns a
436  * list of lines.
437  *
438  * Because this is very slow (the slowest part of autogeneration),
439  * we memoize the results.
440  *)
441 let pod2text ?width ?(trim = true) ?(discard = true) name longdesc =
442   let key = width, trim, discard, name, longdesc in
443   try Hashtbl.find pod2text_memo key
444   with Not_found ->
445     let filename, chan = Filename.open_temp_file "gen" ".tmp" in
446     fprintf chan "=head1 %s\n\n%s\n" name longdesc;
447     close_out chan;
448     let cmd =
449       match width with
450       | Some width ->
451           sprintf "pod2text -w %d %s" width (Filename.quote filename)
452       | None ->
453           sprintf "pod2text %s" (Filename.quote filename) in
454     let chan = open_process_in cmd in
455     let lines = ref [] in
456     let rec loop i =
457       let line = input_line chan in
458       if i = 1 && discard then  (* discard the first line of output *)
459         loop (i+1)
460       else (
461         let line = if trim then triml line else line in
462         lines := line :: !lines;
463         loop (i+1)
464       ) in
465     let lines = try loop 1 with End_of_file -> List.rev !lines in
466     unlink filename;
467     (match close_process_in chan with
468      | WEXITED 0 -> ()
469      | WEXITED i ->
470          failwithf "pod2text: process exited with non-zero status (%d)" i
471      | WSIGNALED i | WSTOPPED i ->
472          failwithf "pod2text: process signalled or stopped by signal %d" i
473     );
474     Hashtbl.add pod2text_memo key lines;
475     pod2text_memo_updated ();
476     lines
477
478 let rec find s sub =
479   let len = String.length s in
480   let sublen = String.length sub in
481   let rec loop i =
482     if i <= len-sublen then (
483       let rec loop2 j =
484         if j < sublen then (
485           if s.[i+j] = sub.[j] then loop2 (j+1)
486           else -1
487         ) else
488           i (* found *)
489       in
490       let r = loop2 0 in
491       if r = -1 then loop (i+1) else r
492     ) else
493       -1 (* not found *)
494   in
495   loop 0
496
497 let rec replace_str s s1 s2 =
498   let len = String.length s in
499   let sublen = String.length s1 in
500   let i = find s s1 in
501   if i = -1 then s
502   else (
503     let s' = String.sub s 0 i in
504     let s'' = String.sub s (i+sublen) (len-i-sublen) in
505     s' ^ s2 ^ replace_str s'' s1 s2
506   )
507
508 let rec string_split sep str =
509   let len = String.length str in
510   let seplen = String.length sep in
511   let i = find str sep in
512   if i = -1 then [str]
513   else (
514     let s' = String.sub str 0 i in
515     let s'' = String.sub str (i+seplen) (len-i-seplen) in
516     s' :: string_split sep s''
517   )
518
519 let files_equal n1 n2 =
520   let cmd = sprintf "cmp -s %s %s" (Filename.quote n1) (Filename.quote n2) in
521   match Sys.command cmd with
522   | 0 -> true
523   | 1 -> false
524   | i -> failwithf "%s: failed with error code %d" cmd i
525
526 let rec filter_map f = function
527   | [] -> []
528   | x :: xs ->
529       match f x with
530       | Some y -> y :: filter_map f xs
531       | None -> filter_map f xs
532
533 let rec find_map f = function
534   | [] -> raise Not_found
535   | x :: xs ->
536       match f x with
537       | Some y -> y
538       | None -> find_map f xs
539
540 let iteri f xs =
541   let rec loop i = function
542     | [] -> ()
543     | x :: xs -> f i x; loop (i+1) xs
544   in
545   loop 0 xs
546
547 let mapi f xs =
548   let rec loop i = function
549     | [] -> []
550     | x :: xs -> let r = f i x in r :: loop (i+1) xs
551   in
552   loop 0 xs
553
554 let count_chars c str =
555   let count = ref 0 in
556   for i = 0 to String.length str - 1 do
557     if c = String.unsafe_get str i then incr count
558   done;
559   !count
560
561 let name_of_argt = function
562   | AHive -> "h"
563   | ANode n | AValue n | AString n | AStringNullable n -> n
564   | AOpenFlags | AUnusedFlags -> "flags"
565   | ASetValues -> "values"
566   | ASetValue -> "val"
567
568 (* Check function names etc. for consistency. *)
569 let check_functions () =
570   let contains_uppercase str =
571     let len = String.length str in
572     let rec loop i =
573       if i >= len then false
574       else (
575         let c = str.[i] in
576         if c >= 'A' && c <= 'Z' then true
577         else loop (i+1)
578       )
579     in
580     loop 0
581   in
582
583   (* Check function names. *)
584   List.iter (
585     fun (name, _, _, _) ->
586       if String.length name >= 7 && String.sub name 0 7 = "hivex" then
587         failwithf "function name %s does not need 'hivex' prefix" name;
588       if name = "" then
589         failwithf "function name is empty";
590       if name.[0] < 'a' || name.[0] > 'z' then
591         failwithf "function name %s must start with lowercase a-z" name;
592       if String.contains name '-' then
593         failwithf "function name %s should not contain '-', use '_' instead."
594           name
595   ) functions;
596
597   (* Check function parameter/return names. *)
598   List.iter (
599     fun (name, style, _, _) ->
600       let check_arg_ret_name n =
601         if contains_uppercase n then
602           failwithf "%s param/ret %s should not contain uppercase chars"
603             name n;
604         if String.contains n '-' || String.contains n '_' then
605           failwithf "%s param/ret %s should not contain '-' or '_'"
606             name n;
607         if n = "value" then
608           failwithf "%s has a param/ret called 'value', which causes conflicts in the OCaml bindings, use something like 'val' or a more descriptive name" name;
609         if n = "int" || n = "char" || n = "short" || n = "long" then
610           failwithf "%s has a param/ret which conflicts with a C type (eg. 'int', 'char' etc.)" name;
611         if n = "i" || n = "n" then
612           failwithf "%s has a param/ret called 'i' or 'n', which will cause some conflicts in the generated code" name;
613         if n = "argv" || n = "args" then
614           failwithf "%s has a param/ret called 'argv' or 'args', which will cause some conflicts in the generated code" name;
615
616         (* List Haskell, OCaml and C keywords here.
617          * http://www.haskell.org/haskellwiki/Keywords
618          * http://caml.inria.fr/pub/docs/manual-ocaml/lex.html#operator-char
619          * http://en.wikipedia.org/wiki/C_syntax#Reserved_keywords
620          * Formatted via: cat c haskell ocaml|sort -u|grep -vE '_|^val$' \
621          *   |perl -pe 's/(.+)/"$1";/'|fmt -70
622          * Omitting _-containing words, since they're handled above.
623          * Omitting the OCaml reserved word, "val", is ok,
624          * and saves us from renaming several parameters.
625          *)
626         let reserved = [
627           "and"; "as"; "asr"; "assert"; "auto"; "begin"; "break"; "case";
628           "char"; "class"; "const"; "constraint"; "continue"; "data";
629           "default"; "deriving"; "do"; "done"; "double"; "downto"; "else";
630           "end"; "enum"; "exception"; "extern"; "external"; "false"; "float";
631           "for"; "forall"; "foreign"; "fun"; "function"; "functor"; "goto";
632           "hiding"; "if"; "import"; "in"; "include"; "infix"; "infixl";
633           "infixr"; "inherit"; "initializer"; "inline"; "instance"; "int";
634           "interface";
635           "land"; "lazy"; "let"; "long"; "lor"; "lsl"; "lsr"; "lxor";
636           "match"; "mdo"; "method"; "mod"; "module"; "mutable"; "new";
637           "newtype"; "object"; "of"; "open"; "or"; "private"; "qualified";
638           "rec"; "register"; "restrict"; "return"; "short"; "sig"; "signed";
639           "sizeof"; "static"; "struct"; "switch"; "then"; "to"; "true"; "try";
640           "type"; "typedef"; "union"; "unsigned"; "virtual"; "void";
641           "volatile"; "when"; "where"; "while";
642           ] in
643         if List.mem n reserved then
644           failwithf "%s has param/ret using reserved word %s" name n;
645       in
646
647       List.iter (fun arg -> check_arg_ret_name (name_of_argt arg)) (snd style)
648   ) functions;
649
650   (* Check short descriptions. *)
651   List.iter (
652     fun (name, _, shortdesc, _) ->
653       if shortdesc.[0] <> Char.lowercase shortdesc.[0] then
654         failwithf "short description of %s should begin with lowercase." name;
655       let c = shortdesc.[String.length shortdesc-1] in
656       if c = '\n' || c = '.' then
657         failwithf "short description of %s should not end with . or \\n." name
658   ) functions;
659
660   (* Check long dscriptions. *)
661   List.iter (
662     fun (name, _, _, longdesc) ->
663       if longdesc.[String.length longdesc-1] = '\n' then
664         failwithf "long description of %s should not end with \\n." name
665   ) functions
666
667 (* 'pr' prints to the current output file. *)
668 let chan = ref Pervasives.stdout
669 let lines = ref 0
670 let pr fs =
671   ksprintf
672     (fun str ->
673        let i = count_chars '\n' str in
674        lines := !lines + i;
675        output_string !chan str
676     ) fs
677
678 let copyright_years =
679   let this_year = 1900 + (localtime (time ())).tm_year in
680   if this_year > 2009 then sprintf "2009-%04d" this_year else "2009"
681
682 (* Generate a header block in a number of standard styles. *)
683 type comment_style =
684   | CStyle | CPlusPlusStyle | HashStyle | OCamlStyle | HaskellStyle
685   | PODCommentStyle
686 type license = GPLv2plus | LGPLv2plus | GPLv2 | LGPLv2
687
688 let generate_header ?(extra_inputs = []) comment license =
689   let inputs = "generator/generator.ml" :: extra_inputs in
690   let c = match comment with
691     | CStyle ->         pr "/* "; " *"
692     | CPlusPlusStyle -> pr "// "; "//"
693     | HashStyle ->      pr "# ";  "#"
694     | OCamlStyle ->     pr "(* "; " *"
695     | HaskellStyle ->   pr "{- "; "  "
696     | PODCommentStyle -> pr "=begin comment\n\n "; "" in
697   pr "hivex generated file\n";
698   pr "%s WARNING: THIS FILE IS GENERATED FROM:\n" c;
699   List.iter (pr "%s   %s\n" c) inputs;
700   pr "%s ANY CHANGES YOU MAKE TO THIS FILE WILL BE LOST.\n" c;
701   pr "%s\n" c;
702   pr "%s Copyright (C) %s Red Hat Inc.\n" c copyright_years;
703   pr "%s Derived from code by Petter Nordahl-Hagen under a compatible license:\n" c;
704   pr "%s   Copyright (c) 1997-2007 Petter Nordahl-Hagen.\n" c;
705   pr "%s Derived from code by Markus Stephany under a compatible license:\n" c;
706   pr "%s   Copyright (c)2000-2004, Markus Stephany.\n" c;
707   pr "%s\n" c;
708   (match license with
709    | GPLv2plus ->
710        pr "%s This program is free software; you can redistribute it and/or modify\n" c;
711        pr "%s it under the terms of the GNU General Public License as published by\n" c;
712        pr "%s the Free Software Foundation; either version 2 of the License, or\n" c;
713        pr "%s (at your option) any later version.\n" c;
714        pr "%s\n" c;
715        pr "%s This program is distributed in the hope that it will be useful,\n" c;
716        pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c;
717        pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the\n" c;
718        pr "%s GNU General Public License for more details.\n" c;
719        pr "%s\n" c;
720        pr "%s You should have received a copy of the GNU General Public License along\n" c;
721        pr "%s with this program; if not, write to the Free Software Foundation, Inc.,\n" c;
722        pr "%s 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.\n" c;
723
724    | LGPLv2plus ->
725        pr "%s This library is free software; you can redistribute it and/or\n" c;
726        pr "%s modify it under the terms of the GNU Lesser General Public\n" c;
727        pr "%s License as published by the Free Software Foundation; either\n" c;
728        pr "%s version 2 of the License, or (at your option) any later version.\n" c;
729        pr "%s\n" c;
730        pr "%s This library is distributed in the hope that it will be useful,\n" c;
731        pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c;
732        pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU\n" c;
733        pr "%s Lesser General Public License for more details.\n" c;
734        pr "%s\n" c;
735        pr "%s You should have received a copy of the GNU Lesser General Public\n" c;
736        pr "%s License along with this library; if not, write to the Free Software\n" c;
737        pr "%s Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA\n" c;
738
739    | GPLv2 ->
740        pr "%s This program is free software; you can redistribute it and/or modify\n" c;
741        pr "%s it under the terms of the GNU General Public License as published by\n" c;
742        pr "%s the Free Software Foundation; version 2 of the License only.\n" c;
743        pr "%s\n" c;
744        pr "%s This program is distributed in the hope that it will be useful,\n" c;
745        pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c;
746        pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the\n" c;
747        pr "%s GNU General Public License for more details.\n" c;
748        pr "%s\n" c;
749        pr "%s You should have received a copy of the GNU General Public License along\n" c;
750        pr "%s with this program; if not, write to the Free Software Foundation, Inc.,\n" c;
751        pr "%s 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.\n" c;
752
753    | LGPLv2 ->
754        pr "%s This library is free software; you can redistribute it and/or\n" c;
755        pr "%s modify it under the terms of the GNU Lesser General Public\n" c;
756        pr "%s License as published by the Free Software Foundation;\n" c;
757        pr "%s version 2.1 of the License only.\n" c;
758        pr "%s\n" c;
759        pr "%s This library is distributed in the hope that it will be useful,\n" c;
760        pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c;
761        pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU\n" c;
762        pr "%s Lesser General Public License for more details.\n" c;
763        pr "%s\n" c;
764        pr "%s You should have received a copy of the GNU Lesser General Public\n" c;
765        pr "%s License along with this library; if not, write to the Free Software\n" c;
766        pr "%s Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA\n" c;
767   );
768   (match comment with
769    | CStyle -> pr " */\n"
770    | CPlusPlusStyle
771    | HashStyle -> ()
772    | OCamlStyle -> pr " *)\n"
773    | HaskellStyle -> pr "-}\n"
774    | PODCommentStyle -> pr "\n=end comment\n"
775   );
776   pr "\n"
777
778 (* Start of main code generation functions below this line. *)
779
780 let rec generate_c_header () =
781   generate_header CStyle LGPLv2;
782
783   pr "\
784 #ifndef HIVEX_H_
785 #define HIVEX_H_
786
787 #include <stdlib.h>
788 #include <stdint.h>
789
790 #ifdef __cplusplus
791 extern \"C\" {
792 #endif
793
794 /* NOTE: This API is documented in the man page hivex(3). */
795
796 /* Hive handle. */
797 typedef struct hive_h hive_h;
798
799 /* Nodes and values. */
800 typedef size_t hive_node_h;
801 typedef size_t hive_value_h;
802
803 #include <errno.h>
804 #ifdef ENOKEY
805 # define HIVEX_NO_KEY ENOKEY
806 #else
807 # define HIVEX_NO_KEY ENOENT
808 #endif
809
810 /* Pre-defined types. */
811 enum hive_type {
812 ";
813   List.iter (
814     fun (t, old_style, new_style, description) ->
815       pr "  /* %s */\n" description;
816       pr "  hive_t_REG_%s,\n" new_style;
817       pr "#define hive_t_%s hive_t_REG_%s\n" old_style new_style;
818       pr "\n"
819   ) hive_types;
820   pr "\
821 };
822
823 typedef enum hive_type hive_type;
824
825 /* Bitmask of flags passed to hivex_open. */
826 ";
827   List.iter (
828     fun (v, flag, description) ->
829       pr "  /* %s */\n" description;
830       pr "#define HIVEX_OPEN_%-10s %d\n" flag v;
831   ) open_flags;
832   pr "\n";
833
834   pr "\
835 /* Array of (key, value) pairs passed to hivex_node_set_values. */
836 struct hive_set_value {
837   char *key;
838   hive_type t;
839   size_t len;
840   char *value;
841 };
842 typedef struct hive_set_value hive_set_value;
843
844 ";
845
846   pr "/* Functions. */\n";
847
848   (* Function declarations. *)
849   List.iter (
850     fun (shortname, style, _, _) ->
851       let name = "hivex_" ^ shortname in
852       generate_c_prototype ~extern:true name style
853   ) functions;
854
855   (* The visitor pattern. *)
856   pr "
857 /* Visit all nodes.  This is specific to the C API and is not made
858  * available to other languages.  This is because of the complexity
859  * of binding callbacks in other languages, but also because other
860  * languages make it much simpler to iterate over a tree.
861  */
862 struct hivex_visitor {
863   int (*node_start) (hive_h *, void *opaque, hive_node_h, const char *name);
864   int (*node_end) (hive_h *, void *opaque, hive_node_h, const char *name);
865   int (*value_string) (hive_h *, void *opaque, hive_node_h, hive_value_h, hive_type t, size_t len, const char *key, const char *str);
866   int (*value_multiple_strings) (hive_h *, void *opaque, hive_node_h, hive_value_h, hive_type t, size_t len, const char *key, char **argv);
867   int (*value_string_invalid_utf16) (hive_h *, void *opaque, hive_node_h, hive_value_h, hive_type t, size_t len, const char *key, const char *str);
868   int (*value_dword) (hive_h *, void *opaque, hive_node_h, hive_value_h, hive_type t, size_t len, const char *key, int32_t);
869   int (*value_qword) (hive_h *, void *opaque, hive_node_h, hive_value_h, hive_type t, size_t len, const char *key, int64_t);
870   int (*value_binary) (hive_h *, void *opaque, hive_node_h, hive_value_h, hive_type t, size_t len, const char *key, const char *value);
871   int (*value_none) (hive_h *, void *opaque, hive_node_h, hive_value_h, hive_type t, size_t len, const char *key, const char *value);
872   int (*value_other) (hive_h *, void *opaque, hive_node_h, hive_value_h, hive_type t, size_t len, const char *key, const char *value);
873   int (*value_any) (hive_h *, void *opaque, hive_node_h, hive_value_h, hive_type t, size_t len, const char *key, const char *value);
874 };
875
876 #define HIVEX_VISIT_SKIP_BAD 1
877
878 extern int hivex_visit (hive_h *h, const struct hivex_visitor *visitor, size_t len, void *opaque, int flags);
879 extern int hivex_visit_node (hive_h *h, hive_node_h node, const struct hivex_visitor *visitor, size_t len, void *opaque, int flags);
880
881 ";
882
883   (* Finish the header file. *)
884   pr "\
885 #ifdef __cplusplus
886 }
887 #endif
888
889 #endif /* HIVEX_H_ */
890 "
891
892 and generate_c_prototype ?(extern = false) name style =
893   if extern then pr "extern ";
894   (match fst style with
895    | RErr -> pr "int "
896    | RErrDispose -> pr "int "
897    | RHive -> pr "hive_h *"
898    | RSize -> pr "size_t "
899    | RNode -> pr "hive_node_h "
900    | RNodeNotFound -> pr "hive_node_h "
901    | RNodeList -> pr "hive_node_h *"
902    | RValue -> pr "hive_value_h "
903    | RValueList -> pr "hive_value_h *"
904    | RString -> pr "char *"
905    | RStringList -> pr "char **"
906    | RLenValue -> pr "hive_value_h "
907    | RLenType -> pr "int "
908    | RLenTypeVal -> pr "char *"
909    | RInt32 -> pr "int32_t "
910    | RInt64 -> pr "int64_t "
911   );
912   pr "%s (" name;
913   let comma = ref false in
914   List.iter (
915     fun arg ->
916       if !comma then pr ", "; comma := true;
917       match arg with
918       | AHive -> pr "hive_h *h"
919       | ANode n -> pr "hive_node_h %s" n
920       | AValue n -> pr "hive_value_h %s" n
921       | AString n | AStringNullable n -> pr "const char *%s" n
922       | AOpenFlags | AUnusedFlags -> pr "int flags"
923       | ASetValues -> pr "size_t nr_values, const hive_set_value *values"
924       | ASetValue -> pr "const hive_set_value *val"
925   ) (snd style);
926   (match fst style with
927    | RLenType | RLenTypeVal -> pr ", hive_type *t, size_t *len"
928    | RLenValue -> pr ", size_t *len"
929    | _ -> ()
930   );
931   pr ");\n"
932
933 and generate_c_pod () =
934   generate_header PODCommentStyle GPLv2;
935
936   pr "\
937   =encoding utf8
938
939 =head1 NAME
940
941 hivex - Windows Registry \"hive\" extraction library
942
943 =head1 SYNOPSIS
944
945  #include <hivex.h>
946
947 ";
948   List.iter (
949     fun (shortname, style, _, _) ->
950       let name = "hivex_" ^ shortname in
951       pr " ";
952       generate_c_prototype ~extern:false name style;
953   ) functions;
954
955   pr "\
956
957 Link with I<-lhivex>.
958
959 =head1 DESCRIPTION
960
961 Hivex is a library for extracting the contents of Windows Registry
962 \"hive\" files.  It is designed to be secure against buggy or malicious
963 registry files.
964
965 Unlike other tools in this area, it doesn't use the textual .REG
966 format, because parsing that is as much trouble as parsing the
967 original binary format.  Instead it makes the file available
968 through a C API, and then wraps this API in higher level scripting
969 and GUI tools.
970
971 There is a separate program to export the hive as XML
972 (see L<hivexml(1)>), or to navigate the file (see L<hivexsh(1)>).
973 There is also a Perl script to export and merge the
974 file as a textual .REG (regedit) file, see L<hivexregedit(1)>.
975
976 If you just want to export or modify the Registry of a Windows
977 virtual machine, you should look at L<virt-win-reg(1)>.
978
979 Hivex is also comes with language bindings for
980 OCaml, Perl, Python and Ruby.
981
982 =head1 TYPES
983
984 =head2 C<hive_h *>
985
986 This handle describes an open hive file.
987
988 =head2 C<hive_node_h>
989
990 This is a node handle, an integer but opaque outside the library.
991 Valid node handles cannot be 0.  The library returns 0 in some
992 situations to indicate an error.
993
994 =head2 C<hive_type>
995
996 The enum below describes the possible types for the value(s)
997 stored at each node.  Note that you should not trust the
998 type field in a Windows Registry, as it very often has no
999 relationship to reality.  Some applications use their own
1000 types.  The encoding of strings is not specified.  Some
1001 programs store everything (including strings) in binary blobs.
1002
1003  enum hive_type {
1004 ";
1005   List.iter (
1006     fun (t, _, new_style, description) ->
1007       pr "   /* %s */\n" description;
1008       pr "   hive_t_REG_%s = %d,\n" new_style t
1009   ) hive_types;
1010   pr "\
1011  };
1012
1013 =head2 C<hive_value_h>
1014
1015 This is a value handle, an integer but opaque outside the library.
1016 Valid value handles cannot be 0.  The library returns 0 in some
1017 situations to indicate an error.
1018
1019 =head2 C<hive_set_value>
1020
1021 The typedef C<hive_set_value> is used in conjunction with the
1022 C<hivex_node_set_values> call described below.
1023
1024  struct hive_set_value {
1025    char *key;     /* key - a UTF-8 encoded ASCIIZ string */
1026    hive_type t;   /* type of value field */
1027    size_t len;    /* length of value field in bytes */
1028    char *value;   /* value field */
1029  };
1030  typedef struct hive_set_value hive_set_value;
1031
1032 To set the default value for a node, you have to pass C<key = \"\">.
1033
1034 Note that the C<value> field is just treated as a list of bytes, and
1035 is stored directly in the hive.  The caller has to ensure correct
1036 encoding and endianness, for example converting dwords to little
1037 endian.
1038
1039 The correct type and encoding for values depends on the node and key
1040 in the registry, the version of Windows, and sometimes even changes
1041 between versions of Windows for the same key.  We don't document it
1042 here.  Often it's not documented at all.
1043
1044 =head1 FUNCTIONS
1045
1046 ";
1047   List.iter (
1048     fun (shortname, style, _, longdesc) ->
1049       let name = "hivex_" ^ shortname in
1050       pr "=head2 %s\n" name;
1051       pr "\n ";
1052       generate_c_prototype ~extern:false name style;
1053       pr "\n";
1054       pr "%s\n" longdesc;
1055       pr "\n";
1056
1057       if List.mem AUnusedFlags (snd style) then
1058         pr "The flags parameter is unused.  Always pass 0.\n\n";
1059
1060       if List.mem ASetValues (snd style) then
1061         pr "C<values> is an array of (key, value) pairs.  There
1062 should be C<nr_values> elements in this array.
1063
1064 Any existing values stored at the node are discarded, and their
1065 C<hive_value_h> handles become invalid.  Thus you can remove all
1066 values stored at C<node> by passing C<nr_values = 0>.\n\n";
1067
1068       if List.mem ASetValue (snd style) then
1069         pr "C<value> is a single (key, value) pair.
1070
1071 Existing C<hive_value_h> handles become invalid.\n\n";
1072
1073       (match fst style with
1074        | RErr ->
1075            pr "\
1076 Returns 0 on success.
1077 On error this returns -1 and sets errno.\n\n"
1078        | RErrDispose ->
1079            pr "\
1080 Returns 0 on success.
1081 On error this returns -1 and sets errno.
1082
1083 This function frees the hive handle (even if it returns an error).
1084 The hive handle must not be used again after calling this function.\n\n"
1085        | RHive ->
1086            pr "\
1087 Returns a new hive handle.
1088 On error this returns NULL and sets errno.\n\n"
1089        | RSize ->
1090            pr "\
1091 Returns a size.
1092 On error this returns 0 and sets errno.\n\n"
1093        | RNode ->
1094            pr "\
1095 Returns a node handle.
1096 On error this returns 0 and sets errno.\n\n"
1097        | RNodeNotFound ->
1098            pr "\
1099 Returns a node handle.
1100 If the node was not found, this returns 0 without setting errno.
1101 On error this returns 0 and sets errno.\n\n"
1102        | RNodeList ->
1103            pr "\
1104 Returns a 0-terminated array of nodes.
1105 The array must be freed by the caller when it is no longer needed.
1106 On error this returns NULL and sets errno.\n\n"
1107        | RValue ->
1108            pr "\
1109 Returns a value handle.
1110 On error this returns 0 and sets errno.\n\n"
1111        | RValueList ->
1112            pr "\
1113 Returns a 0-terminated array of values.
1114 The array must be freed by the caller when it is no longer needed.
1115 On error this returns NULL and sets errno.\n\n"
1116        | RString ->
1117            pr "\
1118 Returns a string.
1119 The string must be freed by the caller when it is no longer needed.
1120 On error this returns NULL and sets errno.\n\n"
1121        | RStringList ->
1122            pr "\
1123 Returns a NULL-terminated array of C strings.
1124 The strings and the array must all be freed by the caller when
1125 they are no longer needed.
1126 On error this returns NULL and sets errno.\n\n"
1127        | RLenType ->
1128            pr "\
1129 Returns 0 on success.
1130 On error this returns -1 and sets errno.\n\n"
1131        | RLenValue ->
1132            pr "\
1133 Returns a value handle.
1134 On error this returns 0 and sets errno.\n\n"
1135        | RLenTypeVal ->
1136            pr "\
1137 The value is returned as an array of bytes (of length C<len>).
1138 The value must be freed by the caller when it is no longer needed.
1139 On error this returns NULL and sets errno.\n\n"
1140        | RInt32 | RInt64 -> ()
1141       );
1142   ) functions;
1143
1144   pr "\
1145 =head1 WRITING TO HIVE FILES
1146
1147 The hivex library supports making limited modifications to hive files.
1148 We have tried to implement this very conservatively in order to reduce
1149 the chance of corrupting your registry.  However you should be careful
1150 and take back-ups, since Microsoft has never documented the hive
1151 format, and so it is possible there are nuances in the
1152 reverse-engineered format that we do not understand.
1153
1154 To be able to modify a hive, you must pass the C<HIVEX_OPEN_WRITE>
1155 flag to C<hivex_open>, otherwise any write operation will return with
1156 errno C<EROFS>.
1157
1158 The write operations shown below do not modify the on-disk file
1159 immediately.  You must call C<hivex_commit> in order to write the
1160 changes to disk.  If you call C<hivex_close> without committing then
1161 any writes are discarded.
1162
1163 Hive files internally consist of a \"memory dump\" of binary blocks
1164 (like the C heap), and some of these blocks can be unused.  The hivex
1165 library never reuses these unused blocks.  Instead, to ensure
1166 robustness in the face of the partially understood on-disk format,
1167 hivex only allocates new blocks after the end of the file, and makes
1168 minimal modifications to existing structures in the file to point to
1169 these new blocks.  This makes hivex slightly less disk-efficient than
1170 it could be, but disk is cheap, and registry modifications tend to be
1171 very small.
1172
1173 When deleting nodes, it is possible that this library may leave
1174 unreachable live blocks in the hive.  This is because certain parts of
1175 the hive disk format such as security (sk) records and big data (db)
1176 records and classname fields are not well understood (and not
1177 documented at all) and we play it safe by not attempting to modify
1178 them.  Apart from wasting a little bit of disk space, it is not
1179 thought that unreachable blocks are a problem.
1180
1181 =head2 WRITE OPERATIONS WHICH ARE NOT SUPPORTED
1182
1183 =over 4
1184
1185 =item *
1186
1187 Changing the root node.
1188
1189 =item *
1190
1191 Creating a new hive file from scratch.  This is impossible at present
1192 because not all fields in the header are understood.  In the hivex
1193 source tree is a file called C<images/minimal> which could be used as
1194 the basis for a new hive (but I<caveat emptor>).
1195
1196 =item *
1197
1198 Modifying or deleting single values at a node.
1199
1200 =item *
1201
1202 Modifying security key (sk) records or classnames.
1203 Previously we did not understand these records.  However now they
1204 are well-understood and we could add support if it was required
1205 (but nothing much really uses them).
1206
1207 =back
1208
1209 =head1 VISITING ALL NODES
1210
1211 The visitor pattern is useful if you want to visit all nodes
1212 in the tree or all nodes below a certain point in the tree.
1213
1214 First you set up your own C<struct hivex_visitor> with your
1215 callback functions.
1216
1217 Each of these callback functions should return 0 on success or -1
1218 on error.  If any callback returns -1, then the entire visit
1219 terminates immediately.  If you don't need a callback function at
1220 all, set the function pointer to NULL.
1221
1222  struct hivex_visitor {
1223    int (*node_start) (hive_h *, void *opaque, hive_node_h, const char *name);
1224    int (*node_end) (hive_h *, void *opaque, hive_node_h, const char *name);
1225    int (*value_string) (hive_h *, void *opaque, hive_node_h, hive_value_h,
1226          hive_type t, size_t len, const char *key, const char *str);
1227    int (*value_multiple_strings) (hive_h *, void *opaque, hive_node_h,
1228          hive_value_h, hive_type t, size_t len, const char *key, char **argv);
1229    int (*value_string_invalid_utf16) (hive_h *, void *opaque, hive_node_h,
1230          hive_value_h, hive_type t, size_t len, const char *key,
1231          const char *str);
1232    int (*value_dword) (hive_h *, void *opaque, hive_node_h, hive_value_h,
1233          hive_type t, size_t len, const char *key, int32_t);
1234    int (*value_qword) (hive_h *, void *opaque, hive_node_h, hive_value_h,
1235          hive_type t, size_t len, const char *key, int64_t);
1236    int (*value_binary) (hive_h *, void *opaque, hive_node_h, hive_value_h,
1237          hive_type t, size_t len, const char *key, const char *value);
1238    int (*value_none) (hive_h *, void *opaque, hive_node_h, hive_value_h,
1239          hive_type t, size_t len, const char *key, const char *value);
1240    int (*value_other) (hive_h *, void *opaque, hive_node_h, hive_value_h,
1241          hive_type t, size_t len, const char *key, const char *value);
1242    /* If value_any callback is not NULL, then the other value_*
1243     * callbacks are not used, and value_any is called on all values.
1244     */
1245    int (*value_any) (hive_h *, void *opaque, hive_node_h, hive_value_h,
1246          hive_type t, size_t len, const char *key, const char *value);
1247  };
1248
1249 =over 4
1250
1251 =item hivex_visit
1252
1253  int hivex_visit (hive_h *h, const struct hivex_visitor *visitor, size_t len, void *opaque, int flags);
1254
1255 Visit all the nodes recursively in the hive C<h>.
1256
1257 C<visitor> should be a C<hivex_visitor> structure with callback
1258 fields filled in as required (unwanted callbacks can be set to
1259 NULL).  C<len> must be the length of the 'visitor' struct (you
1260 should pass C<sizeof (struct hivex_visitor)> for this).
1261
1262 This returns 0 if the whole recursive visit was completed
1263 successfully.  On error this returns -1.  If one of the callback
1264 functions returned an error than we don't touch errno.  If the
1265 error was generated internally then we set errno.
1266
1267 You can skip bad registry entries by setting C<flag> to
1268 C<HIVEX_VISIT_SKIP_BAD>.  If this flag is not set, then a bad registry
1269 causes the function to return an error immediately.
1270
1271 This function is robust if the registry contains cycles or
1272 pointers which are invalid or outside the registry.  It detects
1273 these cases and returns an error.
1274
1275 =item hivex_visit_node
1276
1277  int hivex_visit_node (hive_h *h, hive_node_h node, const struct hivex_visitor *visitor, size_t len, void *opaque);
1278
1279 Same as C<hivex_visit> but instead of starting out at the root, this
1280 starts at C<node>.
1281
1282 =back
1283
1284 =head1 THE STRUCTURE OF THE WINDOWS REGISTRY
1285
1286 Note: To understand the relationship between hives and the common
1287 Windows Registry keys (like C<HKEY_LOCAL_MACHINE>) please see the
1288 Wikipedia page on the Windows Registry.
1289
1290 The Windows Registry is split across various binary files, each
1291 file being known as a \"hive\".  This library only handles a single
1292 hive file at a time.
1293
1294 Hives are n-ary trees with a single root.  Each node in the tree
1295 has a name.
1296
1297 Each node in the tree (including non-leaf nodes) may have an
1298 arbitrary list of (key, value) pairs attached to it.  It may
1299 be the case that one of these pairs has an empty key.  This
1300 is referred to as the default key for the node.
1301
1302 The (key, value) pairs are the place where the useful data is
1303 stored in the registry.  The key is always a string (possibly the
1304 empty string for the default key).  The value is a typed object
1305 (eg. string, int32, binary, etc.).
1306
1307 =head2 RELATIONSHIP TO .REG FILES
1308
1309 The hivex C library does not care about or deal with Windows .REG
1310 files.  Instead we push this complexity up to the Perl
1311 L<Win::Hivex(3)> library and the Perl programs
1312 L<hivexregedit(1)> and L<virt-win-reg(1)>.
1313 Nevertheless it is useful to look at the relationship between the
1314 Registry and .REG files because they are so common.
1315
1316 A .REG file is a textual representation of the registry, or part of the
1317 registry.  The actual registry hives that Windows uses are binary
1318 files.  There are a number of Windows and Linux tools that let you
1319 generate .REG files, or merge .REG files back into the registry hives.
1320 Notable amongst them is Microsoft's REGEDIT program (formerly known as
1321 REGEDT32).
1322
1323 A typical .REG file will contain many sections looking like this:
1324
1325  [HKEY_LOCAL_MACHINE\\SOFTWARE\\Classes\\Stack]
1326  \"@\"=\"Generic Stack\"
1327  \"TileInfo\"=\"prop:System.FileCount\"
1328  \"TilePath\"=str(2):\"%%systemroot%%\\\\system32\"
1329  \"ThumbnailCutoff\"=dword:00000000
1330  \"FriendlyTypeName\"=hex(2):40,00,25,00,53,00,79,00,73,00,74,00,65,00,6d,00,52,00,6f,00,\\
1331   6f,00,74,00,25,00,5c,00,53,00,79,00,73,00,74,00,65,00,6d,00,\\
1332   33,00,32,00,5c,00,73,00,65,00,61,00,72,00,63,00,68,00,66,00,\\
1333   6f,00,6c,00,64,00,65,00,72,00,2e,00,64,00,6c,00,6c,00,2c,00,\\
1334   2d,00,39,00,30,00,32,00,38,00,00,00,d8
1335
1336 Taking this one piece at a time:
1337
1338  [HKEY_LOCAL_MACHINE\\SOFTWARE\\Classes\\Stack]
1339
1340 This is the path to this node in the registry tree.  The first part,
1341 C<HKEY_LOCAL_MACHINE\\SOFTWARE> means that this comes from a hive
1342 file called C<C:\\WINDOWS\\SYSTEM32\\CONFIG\\SOFTWARE>.
1343 C<\\Classes\\Stack> is the real path part,
1344 starting at the root node of the C<SOFTWARE> hive.
1345
1346 Below the node name is a list of zero or more key-value pairs.  Any
1347 interior or leaf node in the registry may have key-value pairs
1348 attached.
1349
1350  \"@\"=\"Generic Stack\"
1351
1352 This is the \"default key\".  In reality (ie. inside the binary hive)
1353 the key string is the empty string.  In .REG files this is written as
1354 C<@> but this has no meaning either in the hives themselves or in this
1355 library.  The value is a string (type 1 - see C<enum hive_type>
1356 above).
1357
1358  \"TileInfo\"=\"prop:System.FileCount\"
1359
1360 This is a regular (key, value) pair, with the value being a type 1
1361 string.  Note that inside the binary file the string is likely to be
1362 UTF-16LE encoded.  This library converts to and from UTF-8 strings
1363 transparently in some cases.
1364
1365  \"TilePath\"=str(2):\"%%systemroot%%\\\\system32\"
1366
1367 The value in this case has type 2 (expanded string) meaning that some
1368 %%...%% variables get expanded by Windows.  (This library doesn't know
1369 or care about variable expansion).
1370
1371  \"ThumbnailCutoff\"=dword:00000000
1372
1373 The value in this case is a dword (type 4).
1374
1375  \"FriendlyTypeName\"=hex(2):40,00,....
1376
1377 This value is an expanded string (type 2) represented in the .REG file
1378 as a series of hex bytes.  In this case the string appears to be a
1379 UTF-16LE string.
1380
1381 =head1 NOTE ON THE USE OF ERRNO
1382
1383 Many functions in this library set errno to indicate errors.  These
1384 are the values of errno you may encounter (this list is not
1385 exhaustive):
1386
1387 =over 4
1388
1389 =item ENOTSUP
1390
1391 Corrupt or unsupported Registry file format.
1392
1393 =item HIVEX_NO_KEY
1394
1395 Missing root key.
1396
1397 =item EINVAL
1398
1399 Passed an invalid argument to the function.
1400
1401 =item EFAULT
1402
1403 Followed a Registry pointer which goes outside
1404 the registry or outside a registry block.
1405
1406 =item ELOOP
1407
1408 Registry contains cycles.
1409
1410 =item ERANGE
1411
1412 Field in the registry out of range.
1413
1414 =item EEXIST
1415
1416 Registry key already exists.
1417
1418 =item EROFS
1419
1420 Tried to write to a registry which is not opened for writing.
1421
1422 =back
1423
1424 =head1 ENVIRONMENT VARIABLES
1425
1426 =over 4
1427
1428 =item HIVEX_DEBUG
1429
1430 Setting HIVEX_DEBUG=1 will enable very verbose messages.  This is
1431 useful for debugging problems with the library itself.
1432
1433 =back
1434
1435 =head1 SEE ALSO
1436
1437 L<hivexget(1)>,
1438 L<hivexml(1)>,
1439 L<hivexsh(1)>,
1440 L<hivexregedit(1)>,
1441 L<virt-win-reg(1)>,
1442 L<Win::Hivex(3)>,
1443 L<guestfs(3)>,
1444 L<http://libguestfs.org/>,
1445 L<virt-cat(1)>,
1446 L<virt-edit(1)>,
1447 L<http://en.wikipedia.org/wiki/Windows_Registry>.
1448
1449 =head1 AUTHORS
1450
1451 Richard W.M. Jones (C<rjones at redhat dot com>)
1452
1453 =head1 COPYRIGHT
1454
1455 Copyright (C) 2009-2010 Red Hat Inc.
1456
1457 Derived from code by Petter Nordahl-Hagen under a compatible license:
1458 Copyright (C) 1997-2007 Petter Nordahl-Hagen.
1459
1460 Derived from code by Markus Stephany under a compatible license:
1461 Copyright (C) 2000-2004 Markus Stephany.
1462
1463 This library is free software; you can redistribute it and/or
1464 modify it under the terms of the GNU Lesser General Public
1465 License as published by the Free Software Foundation;
1466 version 2.1 of the License only.
1467
1468 This library is distributed in the hope that it will be useful,
1469 but WITHOUT ANY WARRANTY; without even the implied warranty of
1470 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
1471 Lesser General Public License for more details.
1472 "
1473
1474 (* Generate the linker script which controls the visibility of
1475  * symbols in the public ABI and ensures no other symbols get
1476  * exported accidentally.
1477  *)
1478 and generate_linker_script () =
1479   generate_header HashStyle GPLv2plus;
1480
1481   let globals = [
1482     "hivex_visit";
1483     "hivex_visit_node"
1484   ] in
1485
1486   let functions =
1487     List.map (fun (name, _, _, _) -> "hivex_" ^ name)
1488       functions in
1489   let globals = List.sort compare (globals @ functions) in
1490
1491   pr "{\n";
1492   pr "    global:\n";
1493   List.iter (pr "        %s;\n") globals;
1494   pr "\n";
1495
1496   pr "    local:\n";
1497   pr "        *;\n";
1498   pr "};\n"
1499
1500 and generate_ocaml_interface () =
1501   generate_header OCamlStyle LGPLv2plus;
1502
1503   pr "\
1504 type t
1505 (** A [hive_h] hive file handle. *)
1506
1507 type node
1508 type value
1509 (** Nodes and values. *)
1510
1511 exception Error of string * Unix.error * string
1512 (** Error raised by a function.
1513
1514     The first parameter is the name of the function which raised the error.
1515     The second parameter is the errno (see the [Unix] module).  The third
1516     parameter is a human-readable string corresponding to the errno.
1517
1518     See hivex(3) for a partial list of interesting errno values that
1519     can be generated by the library. *)
1520 exception Handle_closed of string
1521 (** This exception is raised if you call a function on a closed handle. *)
1522
1523 type hive_type =
1524 ";
1525   iteri (
1526     fun i ->
1527       fun (t, _, new_style, description) ->
1528         assert (i = t);
1529         pr "  | REG_%s (** %s *)\n" new_style description
1530   ) hive_types;
1531
1532   pr "\
1533   | REG_UNKNOWN of int32 (** unknown type *)
1534 (** Hive type field. *)
1535
1536 type open_flag =
1537 ";
1538   iteri (
1539     fun i ->
1540       fun (v, flag, description) ->
1541         assert (1 lsl i = v);
1542         pr "  | OPEN_%s (** %s *)\n" flag description
1543   ) open_flags;
1544
1545   pr "\
1546 (** Open flags for {!open_file} call. *)
1547
1548 type set_value = {
1549   key : string;
1550   t : hive_type;
1551   value : string;
1552 }
1553 (** (key, value) pair passed (as an array) to {!node_set_values}. *)
1554 ";
1555
1556   List.iter (
1557     fun (name, style, shortdesc, _) ->
1558       pr "\n";
1559       generate_ocaml_prototype name style;
1560       pr "(** %s *)\n" shortdesc
1561   ) functions
1562
1563 and generate_ocaml_implementation () =
1564   generate_header OCamlStyle LGPLv2plus;
1565
1566   pr "\
1567 type t
1568 type node = int
1569 type value = int
1570
1571 exception Error of string * Unix.error * string
1572 exception Handle_closed of string
1573
1574 (* Give the exceptions names, so they can be raised from the C code. *)
1575 let () =
1576   Callback.register_exception \"ocaml_hivex_error\"
1577     (Error (\"\", Unix.EUNKNOWNERR 0, \"\"));
1578   Callback.register_exception \"ocaml_hivex_closed\" (Handle_closed \"\")
1579
1580 type hive_type =
1581 ";
1582   iteri (
1583     fun i ->
1584       fun (t, _, new_style, _) ->
1585         assert (i = t);
1586         pr "  | REG_%s\n" new_style
1587   ) hive_types;
1588
1589   pr "\
1590   | REG_UNKNOWN of int32
1591
1592 type open_flag =
1593 ";
1594   iteri (
1595     fun i ->
1596       fun (v, flag, description) ->
1597         assert (1 lsl i = v);
1598         pr "  | OPEN_%s (** %s *)\n" flag description
1599   ) open_flags;
1600
1601   pr "\
1602
1603 type set_value = {
1604   key : string;
1605   t : hive_type;
1606   value : string;
1607 }
1608
1609 ";
1610
1611   List.iter (
1612     fun (name, style, _, _) ->
1613       generate_ocaml_prototype ~is_external:true name style
1614   ) functions
1615
1616 and generate_ocaml_prototype ?(is_external = false) name style =
1617   let ocaml_name = if name = "open" then "open_file" else name in
1618
1619   if is_external then pr "external " else pr "val ";
1620   pr "%s : " ocaml_name;
1621   List.iter (
1622     function
1623     | AHive -> pr "t -> "
1624     | ANode _ -> pr "node -> "
1625     | AValue _ -> pr "value -> "
1626     | AString _ -> pr "string -> "
1627     | AStringNullable _ -> pr "string option -> "
1628     | AOpenFlags -> pr "open_flag list -> "
1629     | AUnusedFlags -> ()
1630     | ASetValues -> pr "set_value array -> "
1631     | ASetValue -> pr "set_value -> "
1632   ) (snd style);
1633   (match fst style with
1634    | RErr -> pr "unit" (* all errors are turned into exceptions *)
1635    | RErrDispose -> pr "unit"
1636    | RHive -> pr "t"
1637    | RSize -> pr "int64"
1638    | RNode -> pr "node"
1639    | RNodeNotFound -> pr "node"
1640    | RNodeList -> pr "node array"
1641    | RValue -> pr "value"
1642    | RValueList -> pr "value array"
1643    | RString -> pr "string"
1644    | RStringList -> pr "string array"
1645    | RLenType -> pr "hive_type * int"
1646    | RLenValue -> pr "int * value"
1647    | RLenTypeVal -> pr "hive_type * string"
1648    | RInt32 -> pr "int32"
1649    | RInt64 -> pr "int64"
1650   );
1651   if is_external then
1652     pr " = \"ocaml_hivex_%s\"" name;
1653   pr "\n"
1654
1655 and generate_ocaml_c () =
1656   generate_header CStyle LGPLv2plus;
1657
1658   pr "\
1659 #include <config.h>
1660
1661 #include <stdio.h>
1662 #include <stdlib.h>
1663 #include <string.h>
1664 #include <stdint.h>
1665 #include <errno.h>
1666
1667 #include <caml/config.h>
1668 #include <caml/alloc.h>
1669 #include <caml/callback.h>
1670 #include <caml/custom.h>
1671 #include <caml/fail.h>
1672 #include <caml/memory.h>
1673 #include <caml/mlvalues.h>
1674 #include <caml/signals.h>
1675
1676 #ifdef HAVE_CAML_UNIXSUPPORT_H
1677 #include <caml/unixsupport.h>
1678 #else
1679 extern value unix_error_of_code (int errcode);
1680 #endif
1681
1682 #ifndef HAVE_CAML_RAISE_WITH_ARGS
1683 static void
1684 caml_raise_with_args (value tag, int nargs, value args[])
1685 {
1686   CAMLparam1 (tag);
1687   CAMLxparamN (args, nargs);
1688   value bucket;
1689   int i;
1690
1691   bucket = caml_alloc_small (1 + nargs, 0);
1692   Field(bucket, 0) = tag;
1693   for (i = 0; i < nargs; i++) Field(bucket, 1 + i) = args[i];
1694   caml_raise(bucket);
1695   CAMLnoreturn;
1696 }
1697 #endif
1698
1699 #include <hivex.h>
1700
1701 #define Hiveh_val(v) (*((hive_h **)Data_custom_val(v)))
1702 static value Val_hiveh (hive_h *);
1703 static int HiveOpenFlags_val (value);
1704 static hive_set_value *HiveSetValue_val (value);
1705 static hive_set_value *HiveSetValues_val (value);
1706 static hive_type HiveType_val (value);
1707 static value Val_hive_type (hive_type);
1708 static value copy_int_array (size_t *);
1709 static value copy_type_len (size_t, hive_type);
1710 static value copy_len_value (size_t, hive_value_h);
1711 static value copy_type_value (const char *, size_t, hive_type);
1712 static void raise_error (const char *) Noreturn;
1713 static void raise_closed (const char *) Noreturn;
1714
1715 ";
1716
1717   (* The wrappers. *)
1718   List.iter (
1719     fun (name, style, _, _) ->
1720       pr "/* Automatically generated wrapper for function\n";
1721       pr " * "; generate_ocaml_prototype name style;
1722       pr " */\n";
1723       pr "\n";
1724
1725       let c_params =
1726         List.map (function
1727                   | ASetValues -> ["nrvalues"; "values"]
1728                   | AUnusedFlags -> ["0"]
1729                   | arg -> [name_of_argt arg]) (snd style) in
1730       let c_params =
1731         match fst style with
1732         | RLenType | RLenTypeVal -> c_params @ [["&t"; "&len"]]
1733         | RLenValue -> c_params @ [["&len"]]
1734         | _ -> c_params in
1735       let c_params = List.concat c_params in
1736
1737       let params =
1738         filter_map (function
1739                     | AUnusedFlags -> None
1740                     | arg -> Some (name_of_argt arg ^ "v")) (snd style) in
1741
1742       pr "/* Emit prototype to appease gcc's -Wmissing-prototypes. */\n";
1743       pr "CAMLprim value ocaml_hivex_%s (value %s" name (List.hd params);
1744       List.iter (pr ", value %s") (List.tl params); pr ");\n";
1745       pr "\n";
1746
1747       pr "CAMLprim value\n";
1748       pr "ocaml_hivex_%s (value %s" name (List.hd params);
1749       List.iter (pr ", value %s") (List.tl params);
1750       pr ")\n";
1751       pr "{\n";
1752
1753       pr "  CAMLparam%d (%s);\n"
1754         (List.length params) (String.concat ", " params);
1755       pr "  CAMLlocal1 (rv);\n";
1756       pr "\n";
1757
1758       List.iter (
1759         function
1760         | AHive ->
1761             pr "  hive_h *h = Hiveh_val (hv);\n";
1762             pr "  if (h == NULL)\n";
1763             pr "    raise_closed (\"%s\");\n" name
1764         | ANode n ->
1765             pr "  hive_node_h %s = Int_val (%sv);\n" n n
1766         | AValue n ->
1767             pr "  hive_value_h %s = Int_val (%sv);\n" n n
1768         | AString n ->
1769             pr "  const char *%s = String_val (%sv);\n" n n
1770         | AStringNullable n ->
1771             pr "  const char *%s =\n" n;
1772             pr "    %sv != Val_int (0) ? String_val (Field (%sv, 0)) : NULL;\n"
1773               n n
1774         | AOpenFlags ->
1775             pr "  int flags = HiveOpenFlags_val (flagsv);\n"
1776         | AUnusedFlags -> ()
1777         | ASetValues ->
1778             pr "  int nrvalues = Wosize_val (valuesv);\n";
1779             pr "  hive_set_value *values = HiveSetValues_val (valuesv);\n"
1780         | ASetValue ->
1781             pr "  hive_set_value *val = HiveSetValue_val (valv);\n"
1782       ) (snd style);
1783       pr "\n";
1784
1785       let error_code =
1786         match fst style with
1787         | RErr -> pr "  int r;\n"; "-1"
1788         | RErrDispose -> pr "  int r;\n"; "-1"
1789         | RHive -> pr "  hive_h *r;\n"; "NULL"
1790         | RSize -> pr "  size_t r;\n"; "0"
1791         | RNode -> pr "  hive_node_h r;\n"; "0"
1792         | RNodeNotFound ->
1793             pr "  errno = 0;\n";
1794             pr "  hive_node_h r;\n";
1795             "0 && errno != 0"
1796         | RNodeList -> pr "  hive_node_h *r;\n"; "NULL"
1797         | RValue -> pr "  hive_value_h r;\n"; "0"
1798         | RValueList -> pr "  hive_value_h *r;\n"; "NULL"
1799         | RString -> pr "  char *r;\n"; "NULL"
1800         | RStringList -> pr "  char **r;\n"; "NULL"
1801         | RLenType ->
1802             pr "  int r;\n";
1803             pr "  size_t len;\n";
1804             pr "  hive_type t;\n";
1805             "-1"
1806         | RLenValue ->
1807             pr "  errno = 0;";
1808             pr "  hive_value_h r;\n";
1809             pr "  size_t len;\n";
1810             "0 && errno != 0"
1811         | RLenTypeVal ->
1812             pr "  char *r;\n";
1813             pr "  size_t len;\n";
1814             pr "  hive_type t;\n";
1815             "NULL"
1816         | RInt32 ->
1817             pr "  errno = 0;\n";
1818             pr "  int32_t r;\n";
1819             "-1 && errno != 0"
1820         | RInt64 ->
1821             pr "  errno = 0;\n";
1822             pr "  int64_t r;\n";
1823             "-1 && errno != 0" in
1824
1825       (* The libguestfs OCaml bindings call enter_blocking_section
1826        * here.  However I don't think that is safe, because we are
1827        * holding pointers to caml strings during the call, and these
1828        * could be moved or freed by other threads.  In any case, there
1829        * is very little reason to enter_blocking_section for any hivex
1830        * call, so don't do it.  XXX
1831        *)
1832       (*pr "  caml_enter_blocking_section ();\n";*)
1833       pr "  r = hivex_%s (%s" name (List.hd c_params);
1834       List.iter (pr ", %s") (List.tl c_params);
1835       pr ");\n";
1836       (*pr "  caml_leave_blocking_section ();\n";*)
1837       pr "\n";
1838
1839       (* Dispose of the hive handle (even if hivex_close returns error). *)
1840       (match fst style with
1841        | RErrDispose ->
1842            pr "  /* So we don't double-free in the finalizer. */\n";
1843            pr "  Hiveh_val (hv) = NULL;\n";
1844            pr "\n";
1845        | _ -> ()
1846       );
1847
1848       List.iter (
1849         function
1850         | AHive | ANode _ | AValue _ | AString _ | AStringNullable _
1851         | AOpenFlags | AUnusedFlags -> ()
1852         | ASetValues ->
1853             pr "  free (values);\n";
1854             pr "\n";
1855         | ASetValue ->
1856             pr "  free (val);\n";
1857             pr "\n";
1858       ) (snd style);
1859
1860       (* Check for errors. *)
1861       pr "  if (r == %s)\n" error_code;
1862       pr "    raise_error (\"%s\");\n" name;
1863       pr "\n";
1864
1865       (match fst style with
1866        | RErr -> pr "  rv = Val_unit;\n"
1867        | RErrDispose -> pr "  rv = Val_unit;\n"
1868        | RHive -> pr "  rv = Val_hiveh (r);\n"
1869        | RSize -> pr "  rv = caml_copy_int64 (r);\n"
1870        | RNode -> pr "  rv = Val_int (r);\n"
1871        | RNodeNotFound ->
1872            pr "  if (r == 0)\n";
1873            pr "    caml_raise_not_found ();\n";
1874            pr "\n";
1875            pr "  rv = Val_int (r);\n"
1876        | RNodeList ->
1877            pr "  rv = copy_int_array (r);\n";
1878            pr "  free (r);\n"
1879        | RValue -> pr "  rv = Val_int (r);\n"
1880        | RValueList ->
1881            pr "  rv = copy_int_array (r);\n";
1882            pr "  free (r);\n"
1883        | RString ->
1884            pr "  rv = caml_copy_string (r);\n";
1885            pr "  free (r);\n"
1886        | RStringList ->
1887            pr "  rv = caml_copy_string_array ((const char **) r);\n";
1888            pr "  for (int i = 0; r[i] != NULL; ++i) free (r[i]);\n";
1889            pr "  free (r);\n"
1890        | RLenType -> pr "  rv = copy_type_len (len, t);\n"
1891        | RLenValue -> pr "  rv = copy_len_value (len, r);\n"
1892        | RLenTypeVal ->
1893            pr "  rv = copy_type_value (r, len, t);\n";
1894            pr "  free (r);\n"
1895        | RInt32 -> pr "  rv = caml_copy_int32 (r);\n"
1896        | RInt64 -> pr "  rv = caml_copy_int64 (r);\n"
1897       );
1898
1899       pr "  CAMLreturn (rv);\n";
1900       pr "}\n";
1901       pr "\n";
1902
1903   ) functions;
1904
1905   pr "\
1906 static int
1907 HiveOpenFlags_val (value v)
1908 {
1909   int flags = 0;
1910   value v2;
1911
1912   while (v != Val_int (0)) {
1913     v2 = Field (v, 0);
1914     flags |= 1 << Int_val (v2);
1915     v = Field (v, 1);
1916   }
1917
1918   return flags;
1919 }
1920
1921 static hive_set_value *
1922 HiveSetValue_val (value v)
1923 {
1924   hive_set_value *val = malloc (sizeof (hive_set_value));
1925
1926   val->key = String_val (Field (v, 0));
1927   val->t = HiveType_val (Field (v, 1));
1928   val->len = caml_string_length (Field (v, 2));
1929   val->value = String_val (Field (v, 2));
1930
1931   return val;
1932 }
1933
1934 static hive_set_value *
1935 HiveSetValues_val (value v)
1936 {
1937   size_t nr_values = Wosize_val (v);
1938   hive_set_value *values = malloc (nr_values * sizeof (hive_set_value));
1939   size_t i;
1940   value v2;
1941
1942   for (i = 0; i < nr_values; ++i) {
1943     v2 = Field (v, i);
1944     values[i].key = String_val (Field (v2, 0));
1945     values[i].t = HiveType_val (Field (v2, 1));
1946     values[i].len = caml_string_length (Field (v2, 2));
1947     values[i].value = String_val (Field (v2, 2));
1948   }
1949
1950   return values;
1951 }
1952
1953 static hive_type
1954 HiveType_val (value v)
1955 {
1956   if (Is_long (v))
1957     return Int_val (v); /* REG_NONE etc. */
1958   else
1959     return Int32_val (Field (v, 0)); /* REG_UNKNOWN of int32 */
1960 }
1961
1962 static value
1963 Val_hive_type (hive_type t)
1964 {
1965   CAMLparam0 ();
1966   CAMLlocal2 (rv, v);
1967
1968   if (t <= %d)
1969     CAMLreturn (Val_int (t));
1970   else {
1971     rv = caml_alloc (1, 0); /* REG_UNKNOWN of int32 */
1972     v = caml_copy_int32 (t);
1973     caml_modify (&Field (rv, 0), v);
1974     CAMLreturn (rv);
1975   }
1976 }
1977
1978 static value
1979 copy_int_array (size_t *xs)
1980 {
1981   CAMLparam0 ();
1982   CAMLlocal2 (v, rv);
1983   size_t nr, i;
1984
1985   for (nr = 0; xs[nr] != 0; ++nr)
1986     ;
1987   if (nr == 0)
1988     CAMLreturn (Atom (0));
1989   else {
1990     rv = caml_alloc (nr, 0);
1991     for (i = 0; i < nr; ++i) {
1992       v = Val_int (xs[i]);
1993       Store_field (rv, i, v); /* Safe because v is not a block. */
1994     }
1995     CAMLreturn (rv);
1996   }
1997 }
1998
1999 static value
2000 copy_type_len (size_t len, hive_type t)
2001 {
2002   CAMLparam0 ();
2003   CAMLlocal2 (v, rv);
2004
2005   rv = caml_alloc (2, 0);
2006   v = Val_hive_type (t);
2007   Store_field (rv, 0, v);
2008   v = Val_int (len);
2009   Store_field (rv, 1, v);
2010   CAMLreturn (rv);
2011 }
2012
2013 static value
2014 copy_len_value (size_t len, hive_value_h r)
2015 {
2016   CAMLparam0 ();
2017   CAMLlocal2 (v, rv);
2018
2019   rv = caml_alloc (2, 0);
2020   v = Val_int (len);
2021   Store_field (rv, 0, v);
2022   v = Val_int (r);
2023   Store_field (rv, 1, v);
2024   CAMLreturn (rv);
2025 }
2026
2027 static value
2028 copy_type_value (const char *r, size_t len, hive_type t)
2029 {
2030   CAMLparam0 ();
2031   CAMLlocal2 (v, rv);
2032
2033   rv = caml_alloc (2, 0);
2034   v = Val_hive_type (t);
2035   Store_field (rv, 0, v);
2036   v = caml_alloc_string (len);
2037   memcpy (String_val (v), r, len);
2038   caml_modify (&Field (rv, 1), v);
2039   CAMLreturn (rv);
2040 }
2041
2042 /* Raise exceptions. */
2043 static void
2044 raise_error (const char *function)
2045 {
2046   /* Save errno early in case it gets trashed. */
2047   int err = errno;
2048
2049   CAMLparam0 ();
2050   CAMLlocal3 (v1, v2, v3);
2051
2052   v1 = caml_copy_string (function);
2053   v2 = unix_error_of_code (err);
2054   v3 = caml_copy_string (strerror (err));
2055   value vvv[] = { v1, v2, v3 };
2056   caml_raise_with_args (*caml_named_value (\"ocaml_hivex_error\"), 3, vvv);
2057
2058   CAMLnoreturn;
2059 }
2060
2061 static void
2062 raise_closed (const char *function)
2063 {
2064   CAMLparam0 ();
2065   CAMLlocal1 (v);
2066
2067   v = caml_copy_string (function);
2068   caml_raise_with_arg (*caml_named_value (\"ocaml_hivex_closed\"), v);
2069
2070   CAMLnoreturn;
2071 }
2072
2073 /* Allocate handles and deal with finalization. */
2074 static void
2075 hivex_finalize (value hv)
2076 {
2077   hive_h *h = Hiveh_val (hv);
2078   if (h) hivex_close (h);
2079 }
2080
2081 static struct custom_operations hivex_custom_operations = {
2082   (char *) \"hivex_custom_operations\",
2083   hivex_finalize,
2084   custom_compare_default,
2085   custom_hash_default,
2086   custom_serialize_default,
2087   custom_deserialize_default
2088 };
2089
2090 static value
2091 Val_hiveh (hive_h *h)
2092 {
2093   CAMLparam0 ();
2094   CAMLlocal1 (rv);
2095
2096   rv = caml_alloc_custom (&hivex_custom_operations,
2097                           sizeof (hive_h *), 0, 1);
2098   Hiveh_val (rv) = h;
2099
2100   CAMLreturn (rv);
2101 }
2102 " max_hive_type
2103
2104 and generate_perl_pm () =
2105   generate_header HashStyle LGPLv2plus;
2106
2107   pr "\
2108 =pod
2109
2110 =head1 NAME
2111
2112 Win::Hivex - Perl bindings for reading and writing Windows Registry hive files
2113
2114 =head1 SYNOPSIS
2115
2116  use Win::Hivex;
2117
2118  $h = Win::Hivex->open ('SOFTWARE');
2119  $root_node = $h->root ();
2120  print $h->node_name ($root_node);
2121
2122 =head1 DESCRIPTION
2123
2124 The C<Win::Hivex> module provides a Perl XS binding to the
2125 L<hivex(3)> API for reading and writing Windows Registry binary
2126 hive files.
2127
2128 =head1 ERRORS
2129
2130 All errors turn into calls to C<croak> (see L<Carp(3)>).
2131
2132 =head1 METHODS
2133
2134 =over 4
2135
2136 =cut
2137
2138 package Win::Hivex;
2139
2140 use strict;
2141 use warnings;
2142
2143 require XSLoader;
2144 XSLoader::load ('Win::Hivex');
2145
2146 =item open
2147
2148  $h = Win::Hivex->open ($filename,";
2149
2150   List.iter (
2151     fun (_, flag, _) ->
2152       pr "\n                        [%s => 1,]" (String.lowercase flag)
2153   ) open_flags;
2154
2155   pr ")
2156
2157 Open a Windows Registry binary hive file.
2158
2159 The C<verbose> and C<debug> flags enable different levels of
2160 debugging messages.
2161
2162 The C<write> flag is required if you will be modifying the
2163 hive file (see L<hivex(3)/WRITING TO HIVE FILES>).
2164
2165 This function returns a hive handle.  The hive handle is
2166 closed automatically when its reference count drops to 0.
2167
2168 =cut
2169
2170 sub open {
2171   my $proto = shift;
2172   my $class = ref ($proto) || $proto;
2173   my $filename = shift;
2174   my %%flags = @_;
2175   my $flags = 0;
2176
2177 ";
2178
2179   List.iter (
2180     fun (n, flag, description) ->
2181       pr "  # %s\n" description;
2182       pr "  $flags += %d if $flags{%s};\n" n (String.lowercase flag)
2183   ) open_flags;
2184
2185   pr "\
2186
2187   my $self = Win::Hivex::_open ($filename, $flags);
2188   bless $self, $class;
2189   return $self;
2190 }
2191
2192 ";
2193
2194   List.iter (
2195     fun (name, style, _, longdesc) ->
2196       (* The close call isn't explicit in Perl: handles are closed
2197        * when their reference count drops to 0.
2198        *
2199        * The open call is coded specially in Perl.
2200        *
2201        * Therefore we don't generate prototypes for these two calls:
2202        *)
2203       if fst style <> RErrDispose && List.hd (snd style) = AHive then (
2204         let longdesc = replace_str longdesc "C<hivex_" "C<" in
2205         pr "=item %s\n\n " name;
2206         generate_perl_prototype name style;
2207         pr "\n\n";
2208         pr "%s\n\n" longdesc;
2209
2210         (match fst style with
2211          | RErr
2212          | RErrDispose
2213          | RHive
2214          | RString
2215          | RStringList
2216          | RLenType
2217          | RLenValue
2218          | RLenTypeVal
2219          | RInt32
2220          | RInt64 -> ()
2221          | RSize ->
2222              pr "\
2223 This returns a size.\n\n"
2224          | RNode ->
2225              pr "\
2226 This returns a node handle.\n\n"
2227          | RNodeNotFound ->
2228              pr "\
2229 This returns a node handle, or C<undef> if the node was not found.\n\n"
2230          | RNodeList ->
2231              pr "\
2232 This returns a list of node handles.\n\n"
2233          | RValue ->
2234              pr "\
2235 This returns a value handle.\n\n"
2236          | RValueList ->
2237              pr "\
2238 This returns a list of value handles.\n\n"
2239         );
2240
2241         if List.mem ASetValues (snd style) then
2242           pr "C<@values> is an array of (keys, value) pairs.
2243 Each element should be a hashref containing C<key>, C<t> (type)
2244 and C<data>.
2245
2246 Any existing values stored at the node are discarded, and their
2247 C<value> handles become invalid.  Thus you can remove all
2248 values stored at C<node> by passing C<@values = []>.\n\n"
2249       )
2250   ) functions;
2251
2252   pr "\
2253 =cut
2254
2255 1;
2256
2257 =back
2258
2259 =head1 COPYRIGHT
2260
2261 Copyright (C) %s Red Hat Inc.
2262
2263 =head1 LICENSE
2264
2265 Please see the file COPYING.LIB for the full license.
2266
2267 =head1 SEE ALSO
2268
2269 L<hivex(3)>,
2270 L<hivexsh(1)>,
2271 L<http://libguestfs.org>,
2272 L<Sys::Guestfs(3)>.
2273
2274 =cut
2275 " copyright_years
2276
2277 and generate_perl_prototype name style =
2278   (* Return type. *)
2279   (match fst style with
2280    | RErr
2281    | RErrDispose -> ()
2282    | RHive -> pr "$h = "
2283    | RSize -> pr "$size = "
2284    | RNode
2285    | RNodeNotFound -> pr "$node = "
2286    | RNodeList -> pr "@nodes = "
2287    | RValue -> pr "$value = "
2288    | RValueList -> pr "@values = "
2289    | RString -> pr "$string = "
2290    | RStringList -> pr "@strings = "
2291    | RLenType -> pr "($type, $len) = "
2292    | RLenValue -> pr "($len, $value) = "
2293    | RLenTypeVal -> pr "($type, $data) = "
2294    | RInt32 -> pr "$int32 = "
2295    | RInt64 -> pr "$int64 = "
2296   );
2297
2298   let args = List.tl (snd style) in
2299
2300   (* AUnusedFlags is dropped in the bindings. *)
2301   let args = List.filter ((<>) AUnusedFlags) args in
2302
2303   pr "$h->%s (" name;
2304
2305   let comma = ref false in
2306   List.iter (
2307     fun arg ->
2308       if !comma then pr ", "; comma := true;
2309       match arg with
2310       | AHive -> pr "$h"
2311       | ANode n
2312       | AValue n
2313       | AString n -> pr "$%s" n
2314       | AStringNullable n -> pr "[$%s|undef]" n
2315       | AOpenFlags -> pr "[flags]"
2316       | AUnusedFlags -> assert false
2317       | ASetValues -> pr "\\@values"
2318       | ASetValue -> pr "$val"
2319   ) args;
2320
2321   pr ")"
2322
2323 and generate_perl_xs () =
2324   generate_header CStyle LGPLv2plus;
2325
2326   pr "\
2327 #include \"EXTERN.h\"
2328 #include \"perl.h\"
2329 #include \"XSUB.h\"
2330
2331 #include <string.h>
2332 #include <hivex.h>
2333 #include <inttypes.h>
2334
2335 static SV *
2336 my_newSVll(long long val) {
2337 #ifdef USE_64_BIT_ALL
2338   return newSViv(val);
2339 #else
2340   char buf[100];
2341   int len;
2342   len = snprintf(buf, 100, \"%%\" PRId64, val);
2343   return newSVpv(buf, len);
2344 #endif
2345 }
2346
2347 #if 0
2348 static SV *
2349 my_newSVull(unsigned long long val) {
2350 #ifdef USE_64_BIT_ALL
2351   return newSVuv(val);
2352 #else
2353   char buf[100];
2354   int len;
2355   len = snprintf(buf, 100, \"%%\" PRIu64, val);
2356   return newSVpv(buf, len);
2357 #endif
2358 }
2359 #endif
2360
2361 #if 0
2362 /* http://www.perlmonks.org/?node_id=680842 */
2363 static char **
2364 XS_unpack_charPtrPtr (SV *arg) {
2365   char **ret;
2366   AV *av;
2367   I32 i;
2368
2369   if (!arg || !SvOK (arg) || !SvROK (arg) || SvTYPE (SvRV (arg)) != SVt_PVAV)
2370     croak (\"array reference expected\");
2371
2372   av = (AV *)SvRV (arg);
2373   ret = malloc ((av_len (av) + 1 + 1) * sizeof (char *));
2374   if (!ret)
2375     croak (\"malloc failed\");
2376
2377   for (i = 0; i <= av_len (av); i++) {
2378     SV **elem = av_fetch (av, i, 0);
2379
2380     if (!elem || !*elem)
2381       croak (\"missing element in list\");
2382
2383     ret[i] = SvPV_nolen (*elem);
2384   }
2385
2386   ret[i] = NULL;
2387
2388   return ret;
2389 }
2390 #endif
2391
2392 /* Handle set_values parameter. */
2393 typedef struct pl_set_values {
2394   size_t nr_values;
2395   hive_set_value *values;
2396 } pl_set_values;
2397
2398 static pl_set_values
2399 unpack_pl_set_values (SV *sv)
2400 {
2401   pl_set_values ret;
2402   AV *av;
2403   I32 i;
2404
2405   if (!sv || !SvOK (sv) || !SvROK (sv) || SvTYPE (SvRV (sv)) != SVt_PVAV)
2406     croak (\"array reference expected\");
2407
2408   av = (AV *)SvRV(sv);
2409   ret.nr_values = av_len (av) + 1;
2410   ret.values = malloc (ret.nr_values * sizeof (hive_set_value));
2411   if (!ret.values)
2412     croak (\"malloc failed\");
2413
2414   for (i = 0; i <= av_len (av); i++) {
2415     SV **hvp = av_fetch (av, i, 0);
2416
2417     if (!hvp || !*hvp || !SvROK (*hvp) || SvTYPE (SvRV (*hvp)) != SVt_PVHV)
2418       croak (\"missing element in list or not a hash ref\");
2419
2420     HV *hv = (HV *)SvRV(*hvp);
2421
2422     SV **svp;
2423     svp = hv_fetch (hv, \"key\", 3, 0);
2424     if (!svp || !*svp)
2425       croak (\"missing 'key' in hash\");
2426     ret.values[i].key = SvPV_nolen (*svp);
2427
2428     svp = hv_fetch (hv, \"t\", 1, 0);
2429     if (!svp || !*svp)
2430       croak (\"missing 't' in hash\");
2431     ret.values[i].t = SvIV (*svp);
2432
2433     svp = hv_fetch (hv, \"value\", 5, 0);
2434     if (!svp || !*svp)
2435       croak (\"missing 'value' in hash\");
2436     ret.values[i].value = SvPV (*svp, ret.values[i].len);
2437   }
2438
2439   return ret;
2440 }
2441
2442 static hive_set_value *
2443 unpack_set_value (SV *sv)
2444 {
2445   hive_set_value *ret;
2446
2447   if (!sv || !SvROK (sv) || SvTYPE (SvRV (sv)) != SVt_PVHV)
2448     croak (\"not a hash ref\");
2449
2450   ret = malloc (sizeof (hive_set_value));
2451   if (ret == NULL)
2452     croak (\"malloc failed\");
2453
2454   HV *hv = (HV *)SvRV(sv);
2455
2456   SV **svp;
2457   svp = hv_fetch (hv, \"key\", 3, 0);
2458   if (!svp || !*svp)
2459     croak (\"missing 'key' in hash\");
2460   ret->key = SvPV_nolen (*svp);
2461
2462   svp = hv_fetch (hv, \"t\", 1, 0);
2463   if (!svp || !*svp)
2464     croak (\"missing 't' in hash\");
2465   ret->t = SvIV (*svp);
2466
2467   svp = hv_fetch (hv, \"value\", 5, 0);
2468   if (!svp || !*svp)
2469     croak (\"missing 'value' in hash\");
2470   ret->value = SvPV (*svp, ret->len);
2471
2472   return ret;
2473 }
2474
2475 MODULE = Win::Hivex  PACKAGE = Win::Hivex
2476
2477 PROTOTYPES: ENABLE
2478
2479 hive_h *
2480 _open (filename, flags)
2481       char *filename;
2482       int flags;
2483    CODE:
2484       RETVAL = hivex_open (filename, flags);
2485       if (!RETVAL)
2486         croak (\"hivex_open: %%s: %%s\", filename, strerror (errno));
2487  OUTPUT:
2488       RETVAL
2489
2490 void
2491 DESTROY (h)
2492       hive_h *h;
2493  PPCODE:
2494       if (hivex_close (h) == -1)
2495         croak (\"hivex_close: %%s\", strerror (errno));
2496
2497 ";
2498
2499   List.iter (
2500     fun (name, style, _, longdesc) ->
2501       (* The close and open calls are handled specially above. *)
2502       if fst style <> RErrDispose && List.hd (snd style) = AHive then (
2503         (match fst style with
2504          | RErr -> pr "void\n"
2505          | RErrDispose -> failwith "perl bindings cannot handle a call which disposes of the handle"
2506          | RHive -> failwith "perl bindings cannot handle a call which returns a handle"
2507          | RSize
2508          | RNode
2509          | RNodeNotFound
2510          | RValue
2511          | RString -> pr "SV *\n"
2512          | RNodeList
2513          | RValueList
2514          | RStringList
2515          | RLenType
2516          | RLenValue
2517          | RLenTypeVal -> pr "void\n"
2518          | RInt32 -> pr "SV *\n"
2519          | RInt64 -> pr "SV *\n"
2520         );
2521
2522         (* Call and arguments. *)
2523         let perl_params =
2524           filter_map (function
2525                       | AUnusedFlags -> None
2526                       | arg -> Some (name_of_argt arg)) (snd style) in
2527
2528         let c_params =
2529           List.map (function
2530                     | AUnusedFlags -> "0"
2531                     | ASetValues -> "values.nr_values, values.values"
2532                     | arg -> name_of_argt arg) (snd style) in
2533
2534         pr "%s (%s)\n" name (String.concat ", " perl_params);
2535         iteri (
2536           fun i ->
2537             function
2538             | AHive ->
2539                 pr "      hive_h *h;\n"
2540             | ANode n
2541             | AValue n ->
2542                 pr "      int %s;\n" n
2543             | AString n ->
2544                 pr "      char *%s;\n" n
2545             | AStringNullable n ->
2546                 (* http://www.perlmonks.org/?node_id=554277 *)
2547                 pr "      char *%s = SvOK(ST(%d)) ? SvPV_nolen(ST(%d)) : NULL;\n" n i i
2548             | AOpenFlags ->
2549                 pr "      int flags;\n"
2550             | AUnusedFlags -> ()
2551             | ASetValues ->
2552                 pr "      pl_set_values values = unpack_pl_set_values (ST(%d));\n" i
2553             | ASetValue ->
2554                 pr "      hive_set_value *val = unpack_set_value (ST(%d));\n" i
2555         ) (snd style);
2556
2557         let free_args () =
2558           List.iter (
2559             function
2560             | ASetValues ->
2561                 pr "      free (values.values);\n"
2562             | ASetValue ->
2563                 pr "      free (val);\n"
2564             | AHive | ANode _ | AValue _ | AString _ | AStringNullable _
2565             | AOpenFlags | AUnusedFlags -> ()
2566           ) (snd style)
2567         in
2568
2569         (* Code. *)
2570         (match fst style with
2571          | RErr ->
2572              pr "PREINIT:\n";
2573              pr "      int r;\n";
2574              pr " PPCODE:\n";
2575              pr "      r = hivex_%s (%s);\n"
2576                name (String.concat ", " c_params);
2577              free_args ();
2578              pr "      if (r == -1)\n";
2579              pr "        croak (\"%%s: %%s\", \"%s\", strerror (errno));\n"
2580                name;
2581
2582          | RErrDispose -> assert false
2583          | RHive -> assert false
2584
2585          | RSize
2586          | RNode
2587          | RValue ->
2588              pr "PREINIT:\n";
2589              pr "      /* hive_node_h = hive_value_h = size_t so we cheat\n";
2590              pr "         here to simplify the generator */\n";
2591              pr "      size_t r;\n";
2592              pr "   CODE:\n";
2593              pr "      r = hivex_%s (%s);\n"
2594                name (String.concat ", " c_params);
2595              free_args ();
2596              pr "      if (r == 0)\n";
2597              pr "        croak (\"%%s: %%s\", \"%s\", strerror (errno));\n"
2598                name;
2599              pr "      RETVAL = newSViv (r);\n";
2600              pr " OUTPUT:\n";
2601              pr "      RETVAL\n"
2602
2603          | RNodeNotFound ->
2604              pr "PREINIT:\n";
2605              pr "      hive_node_h r;\n";
2606              pr "   CODE:\n";
2607              pr "      errno = 0;\n";
2608              pr "      r = hivex_%s (%s);\n"
2609                name (String.concat ", " c_params);
2610              free_args ();
2611              pr "      if (r == 0 && errno != 0)\n";
2612              pr "        croak (\"%%s: %%s\", \"%s\", strerror (errno));\n"
2613                name;
2614              pr "      if (r == 0)\n";
2615              pr "        RETVAL = &PL_sv_undef;\n";
2616              pr "      else\n";
2617              pr "        RETVAL = newSViv (r);\n";
2618              pr " OUTPUT:\n";
2619              pr "      RETVAL\n"
2620
2621          | RString ->
2622              pr "PREINIT:\n";
2623              pr "      char *r;\n";
2624              pr "   CODE:\n";
2625              pr "      r = hivex_%s (%s);\n"
2626                name (String.concat ", " c_params);
2627              free_args ();
2628              pr "      if (r == NULL)\n";
2629              pr "        croak (\"%%s: %%s\", \"%s\", strerror (errno));\n"
2630                name;
2631              pr "      RETVAL = newSVpv (r, 0);\n";
2632              pr "      free (r);\n";
2633              pr " OUTPUT:\n";
2634              pr "      RETVAL\n"
2635
2636          | RNodeList
2637          | RValueList ->
2638              pr "PREINIT:\n";
2639              pr "      size_t *r;\n";
2640              pr "      int i, n;\n";
2641              pr " PPCODE:\n";
2642              pr "      r = hivex_%s (%s);\n"
2643                name (String.concat ", " c_params);
2644              free_args ();
2645              pr "      if (r == NULL)\n";
2646              pr "        croak (\"%%s: %%s\", \"%s\", strerror (errno));\n"
2647                name;
2648              pr "      for (n = 0; r[n] != 0; ++n) /**/;\n";
2649              pr "      EXTEND (SP, n);\n";
2650              pr "      for (i = 0; i < n; ++i)\n";
2651              pr "        PUSHs (sv_2mortal (newSViv (r[i])));\n";
2652              pr "      free (r);\n";
2653
2654          | RStringList ->
2655              pr "PREINIT:\n";
2656              pr "      char **r;\n";
2657              pr "      int i, n;\n";
2658              pr " PPCODE:\n";
2659              pr "      r = hivex_%s (%s);\n"
2660                name (String.concat ", " c_params);
2661              free_args ();
2662              pr "      if (r == NULL)\n";
2663              pr "        croak (\"%%s: %%s\", \"%s\", strerror (errno));\n"
2664                name;
2665              pr "      for (n = 0; r[n] != NULL; ++n) /**/;\n";
2666              pr "      EXTEND (SP, n);\n";
2667              pr "      for (i = 0; i < n; ++i) {\n";
2668              pr "        PUSHs (sv_2mortal (newSVpv (r[i], 0)));\n";
2669              pr "        free (r[i]);\n";
2670              pr "      }\n";
2671              pr "      free (r);\n";
2672
2673          | RLenType ->
2674              pr "PREINIT:\n";
2675              pr "      int r;\n";
2676              pr "      size_t len;\n";
2677              pr "      hive_type type;\n";
2678              pr " PPCODE:\n";
2679              pr "      r = hivex_%s (%s, &type, &len);\n"
2680                name (String.concat ", " c_params);
2681              free_args ();
2682              pr "      if (r == -1)\n";
2683              pr "        croak (\"%%s: %%s\", \"%s\", strerror (errno));\n"
2684                name;
2685              pr "      EXTEND (SP, 2);\n";
2686              pr "      PUSHs (sv_2mortal (newSViv (type)));\n";
2687              pr "      PUSHs (sv_2mortal (newSViv (len)));\n";
2688
2689          | RLenValue ->
2690              pr "PREINIT:\n";
2691              pr "      hive_value_h r;\n";
2692              pr "      size_t len;\n";
2693              pr " PPCODE:\n";
2694              pr "      errno = 0;\n";
2695              pr "      r = hivex_%s (%s, &len);\n"
2696                name (String.concat ", " c_params);
2697              free_args ();
2698              pr "      if (r == 0 && errno)\n";
2699              pr "        croak (\"%%s: \", \"%s\", strerror (errno));\n"
2700                name;
2701              pr "      EXTEND (SP, 2);\n";
2702              pr "      PUSHs (sv_2mortal (newSViv (len)));\n";
2703              pr "      PUSHs (sv_2mortal (newSViv (r)));\n";
2704
2705          | RLenTypeVal ->
2706              pr "PREINIT:\n";
2707              pr "      char *r;\n";
2708              pr "      size_t len;\n";
2709              pr "      hive_type type;\n";
2710              pr " PPCODE:\n";
2711              pr "      r = hivex_%s (%s, &type, &len);\n"
2712                name (String.concat ", " c_params);
2713              free_args ();
2714              pr "      if (r == NULL)\n";
2715              pr "        croak (\"%%s: %%s\", \"%s\", strerror (errno));\n"
2716                name;
2717              pr "      EXTEND (SP, 2);\n";
2718              pr "      PUSHs (sv_2mortal (newSViv (type)));\n";
2719              pr "      PUSHs (sv_2mortal (newSVpvn (r, len)));\n";
2720              pr "      free (r);\n";
2721
2722          | RInt32 ->
2723              pr "PREINIT:\n";
2724              pr "      int32_t r;\n";
2725              pr "   CODE:\n";
2726              pr "      errno = 0;\n";
2727              pr "      r = hivex_%s (%s);\n"
2728                name (String.concat ", " c_params);
2729              free_args ();
2730              pr "      if (r == -1 && errno != 0)\n";
2731              pr "        croak (\"%%s: %%s\", \"%s\", strerror (errno));\n"
2732                name;
2733              pr "      RETVAL = newSViv (r);\n";
2734              pr " OUTPUT:\n";
2735              pr "      RETVAL\n"
2736
2737          | RInt64 ->
2738              pr "PREINIT:\n";
2739              pr "      int64_t r;\n";
2740              pr "   CODE:\n";
2741              pr "      errno = 0;\n";
2742              pr "      r = hivex_%s (%s);\n"
2743                name (String.concat ", " c_params);
2744              free_args ();
2745              pr "      if (r == -1 && errno != 0)\n";
2746              pr "        croak (\"%%s: %%s\", \"%s\", strerror (errno));\n"
2747                name;
2748              pr "      RETVAL = my_newSVll (r);\n";
2749              pr " OUTPUT:\n";
2750              pr "      RETVAL\n"
2751         );
2752         pr "\n"
2753       )
2754   ) functions
2755
2756 and generate_python_c () =
2757   generate_header CStyle LGPLv2plus;
2758
2759   pr "\
2760 #include <config.h>
2761
2762 #define PY_SSIZE_T_CLEAN 1
2763 #include <Python.h>
2764
2765 #if PY_VERSION_HEX < 0x02050000
2766 typedef int Py_ssize_t;
2767 #define PY_SSIZE_T_MAX INT_MAX
2768 #define PY_SSIZE_T_MIN INT_MIN
2769 #endif
2770
2771 #include <stdio.h>
2772 #include <stdlib.h>
2773 #include <assert.h>
2774
2775 #include \"hivex.h\"
2776
2777 #ifndef HAVE_PYCAPSULE_NEW
2778 typedef struct {
2779   PyObject_HEAD
2780   hive_h *h;
2781 } Pyhivex_Object;
2782 #endif
2783
2784 static hive_h *
2785 get_handle (PyObject *obj)
2786 {
2787   assert (obj);
2788   assert (obj != Py_None);
2789 #ifndef HAVE_PYCAPSULE_NEW
2790   return ((Pyhivex_Object *) obj)->h;
2791 #else
2792   return (hive_h *) PyCapsule_GetPointer(obj, \"hive_h\");
2793 #endif
2794 }
2795
2796 static PyObject *
2797 put_handle (hive_h *h)
2798 {
2799   assert (h);
2800 #ifndef HAVE_PYCAPSULE_NEW
2801   return
2802     PyCObject_FromVoidPtrAndDesc ((void *) h, (char *) \"hive_h\", NULL);
2803 #else
2804   return PyCapsule_New ((void *) h, \"hive_h\", NULL);
2805 #endif
2806 }
2807
2808 /* This returns pointers into the Python objects, which should
2809  * not be freed.
2810  */
2811 static int
2812 get_value (PyObject *v, hive_set_value *ret)
2813 {
2814   PyObject *obj;
2815 #ifndef HAVE_PYSTRING_ASSTRING
2816   PyObject *bytes;
2817 #endif
2818
2819   obj = PyDict_GetItemString (v, \"key\");
2820   if (!obj) {
2821     PyErr_SetString (PyExc_RuntimeError, \"no 'key' element in dictionary\");
2822     return -1;
2823   }
2824 #ifdef HAVE_PYSTRING_ASSTRING
2825   ret->key = PyString_AsString (obj);
2826 #else
2827   bytes = PyUnicode_AsUTF8String (obj);
2828   ret->key = PyBytes_AS_STRING (bytes);
2829 #endif
2830
2831   obj = PyDict_GetItemString (v, \"t\");
2832   if (!obj) {
2833     PyErr_SetString (PyExc_RuntimeError, \"no 't' element in dictionary\");
2834     return -1;
2835   }
2836   ret->t = PyLong_AsLong (obj);
2837
2838   obj = PyDict_GetItemString (v, \"value\");
2839   if (!obj) {
2840     PyErr_SetString (PyExc_RuntimeError, \"no 'value' element in dictionary\");
2841     return -1;
2842   }
2843 #ifdef HAVE_PYSTRING_ASSTRING
2844   ret->value = PyString_AsString (obj);
2845   ret->len = PyString_Size (obj);
2846 #else
2847   bytes = PyUnicode_AsUTF8String (obj);
2848   ret->value = PyBytes_AS_STRING (bytes);
2849   ret->len = PyBytes_GET_SIZE (bytes);
2850 #endif
2851
2852   return 0;
2853 }
2854
2855 typedef struct py_set_values {
2856   size_t nr_values;
2857   hive_set_value *values;
2858 } py_set_values;
2859
2860 static int
2861 get_values (PyObject *v, py_set_values *ret)
2862 {
2863   Py_ssize_t slen;
2864   size_t len, i;
2865
2866   if (!PyList_Check (v)) {
2867     PyErr_SetString (PyExc_RuntimeError, \"expecting a list parameter\");
2868     return -1;
2869   }
2870
2871   slen = PyList_Size (v);
2872   if (slen < 0) {
2873     PyErr_SetString (PyExc_RuntimeError, \"get_string_list: PyList_Size failure\");
2874     return -1;
2875   }
2876   len = (size_t) slen;
2877   ret->nr_values = len;
2878   ret->values = malloc (len * sizeof (hive_set_value));
2879   if (!ret->values) {
2880     PyErr_SetString (PyExc_RuntimeError, strerror (errno));
2881     return -1;
2882   }
2883
2884   for (i = 0; i < len; ++i) {
2885     if (get_value (PyList_GetItem (v, i), &(ret->values[i])) == -1) {
2886       free (ret->values);
2887       return -1;
2888     }
2889   }
2890
2891   return 0;
2892 }
2893
2894 static PyObject *
2895 put_string_list (char * const * const argv)
2896 {
2897   PyObject *list;
2898   size_t argc, i;
2899
2900   for (argc = 0; argv[argc] != NULL; ++argc)
2901     ;
2902
2903   list = PyList_New (argc);
2904   for (i = 0; i < argc; ++i) {
2905 #ifdef HAVE_PYSTRING_ASSTRING
2906     PyList_SetItem (list, i, PyString_FromString (argv[i]));
2907 #else
2908     PyList_SetItem (list, i, PyUnicode_FromString (argv[i]));
2909 #endif
2910   }
2911
2912   return list;
2913 }
2914
2915 static void
2916 free_strings (char **argv)
2917 {
2918   size_t argc;
2919
2920   for (argc = 0; argv[argc] != NULL; ++argc)
2921     free (argv[argc]);
2922   free (argv);
2923 }
2924
2925 /* Since hive_node_t is the same as hive_value_t this also works for values. */
2926 static PyObject *
2927 put_node_list (hive_node_h *nodes)
2928 {
2929   PyObject *list;
2930   size_t argc, i;
2931
2932   for (argc = 0; nodes[argc] != 0; ++argc)
2933     ;
2934
2935   list = PyList_New (argc);
2936   for (i = 0; i < argc; ++i)
2937     PyList_SetItem (list, i, PyLong_FromLongLong ((long) nodes[i]));
2938
2939   return list;
2940 }
2941
2942 static PyObject *
2943 put_len_type (size_t len, hive_type t)
2944 {
2945   PyObject *r = PyTuple_New (2);
2946   PyTuple_SetItem (r, 0, PyLong_FromLong ((long) t));
2947   PyTuple_SetItem (r, 1, PyLong_FromLongLong ((long) len));
2948   return r;
2949 }
2950
2951 static PyObject *
2952 put_len_val (size_t len, hive_value_h value)
2953 {
2954   PyObject *r = PyTuple_New (2);
2955   PyTuple_SetItem (r, 0, PyLong_FromLongLong ((long) len));
2956   PyTuple_SetItem (r, 1, PyLong_FromLongLong ((long) value));
2957   return r;
2958 }
2959
2960 static PyObject *
2961 put_val_type (char *val, size_t len, hive_type t)
2962 {
2963   PyObject *r = PyTuple_New (2);
2964   PyTuple_SetItem (r, 0, PyLong_FromLong ((long) t));
2965 #ifdef HAVE_PYSTRING_ASSTRING
2966   PyTuple_SetItem (r, 1, PyString_FromStringAndSize (val, len));
2967 #else
2968   PyTuple_SetItem (r, 1, PyBytes_FromStringAndSize (val, len));
2969 #endif
2970   return r;
2971 }
2972
2973 ";
2974
2975   (* Generate functions. *)
2976   List.iter (
2977     fun (name, style, _, longdesc) ->
2978       pr "static PyObject *\n";
2979       pr "py_hivex_%s (PyObject *self, PyObject *args)\n" name;
2980       pr "{\n";
2981       pr "  PyObject *py_r;\n";
2982
2983       let error_code =
2984         match fst style with
2985         | RErr -> pr "  int r;\n"; "-1"
2986         | RErrDispose -> pr "  int r;\n"; "-1"
2987         | RHive -> pr "  hive_h *r;\n"; "NULL"
2988         | RSize -> pr "  size_t r;\n"; "0"
2989         | RNode -> pr "  hive_node_h r;\n"; "0"
2990         | RNodeNotFound ->
2991             pr "  errno = 0;\n";
2992             pr "  hive_node_h r;\n";
2993             "0 && errno != 0"
2994         | RNodeList -> pr "  hive_node_h *r;\n"; "NULL"
2995         | RValue -> pr "  hive_value_h r;\n"; "0"
2996         | RValueList -> pr "  hive_value_h *r;\n"; "NULL"
2997         | RString -> pr "  char *r;\n"; "NULL"
2998         | RStringList -> pr "  char **r;\n"; "NULL"
2999         | RLenType ->
3000             pr "  int r;\n";
3001             pr "  size_t len;\n";
3002             pr "  hive_type t;\n";
3003             "-1"
3004         | RLenValue ->
3005             pr "  errno = 0;\n";
3006             pr "  int r;\n";
3007             pr "  size_t len;\n";
3008             "0 && errno != 0"
3009         | RLenTypeVal ->
3010             pr "  char *r;\n";
3011             pr "  size_t len;\n";
3012             pr "  hive_type t;\n";
3013             "NULL"
3014         | RInt32 ->
3015             pr "  errno = 0;\n";
3016             pr "  int32_t r;\n";
3017             "-1 && errno != 0"
3018         | RInt64 ->
3019             pr "  errno = 0;\n";
3020             pr "  int64_t r;\n";
3021             "-1 && errno != 0" in
3022
3023       (* Call and arguments. *)
3024       let c_params =
3025         List.map (function
3026                   | AUnusedFlags -> "0"
3027                   | ASetValues -> "values.nr_values, values.values"
3028                   | ASetValue -> "&val"
3029                   | arg -> name_of_argt arg) (snd style) in
3030       let c_params =
3031         match fst style with
3032         | RLenType | RLenTypeVal -> c_params @ ["&t"; "&len"]
3033         | RLenValue -> c_params @ ["&len"]
3034         | _ -> c_params in
3035
3036       List.iter (
3037         function
3038         | AHive ->
3039             pr "  hive_h *h;\n";
3040             pr "  PyObject *py_h;\n"
3041         | ANode n
3042         | AValue n ->
3043             pr "  long %s;\n" n
3044         | AString n
3045         | AStringNullable n ->
3046             pr "  char *%s;\n" n
3047         | AOpenFlags ->
3048             pr "  int flags;\n"
3049         | AUnusedFlags -> ()
3050         | ASetValues ->
3051             pr "  py_set_values values;\n";
3052             pr "  PyObject *py_values;\n"
3053         | ASetValue ->
3054             pr "  hive_set_value val;\n";
3055             pr "  PyObject *py_val;\n"
3056       ) (snd style);
3057
3058       pr "\n";
3059
3060       (* Convert the required parameters. *)
3061       pr "  if (!PyArg_ParseTuple (args, (char *) \"";
3062       List.iter (
3063         function
3064         | AHive ->
3065             pr "O"
3066         | ANode n
3067         | AValue n ->
3068             pr "l"
3069         | AString n ->
3070             pr "s"
3071         | AStringNullable n ->
3072             pr "z"
3073         | AOpenFlags ->
3074             pr "i"
3075         | AUnusedFlags -> ()
3076         | ASetValues
3077         | ASetValue ->
3078             pr "O"
3079       ) (snd style);
3080
3081       pr ":hivex_%s\"" name;
3082
3083       List.iter (
3084         function
3085         | AHive ->
3086             pr ", &py_h"
3087         | ANode n
3088         | AValue n ->
3089             pr ", &%s" n
3090         | AString n
3091         | AStringNullable n ->
3092             pr ", &%s" n
3093         | AOpenFlags ->
3094             pr ", &flags"
3095         | AUnusedFlags -> ()
3096         | ASetValues ->
3097             pr ", &py_values"
3098         | ASetValue ->
3099             pr ", &py_val"
3100         ) (snd style);
3101
3102       pr "))\n";
3103       pr "    return NULL;\n";
3104
3105       (* Convert some Python argument types to C. *)
3106       List.iter (
3107         function
3108         | AHive ->
3109             pr "  h = get_handle (py_h);\n"
3110         | ANode _
3111         | AValue _
3112         | AString _
3113         | AStringNullable _
3114         | AOpenFlags
3115         | AUnusedFlags -> ()
3116         | ASetValues ->
3117             pr "  if (get_values (py_values, &values) == -1)\n";
3118             pr "    return NULL;\n"
3119         | ASetValue ->
3120             pr "  if (get_value (py_val, &val) == -1)\n";
3121             pr "    return NULL;\n"
3122       ) (snd style);
3123
3124       (* Call the C function. *)
3125       pr "  r = hivex_%s (%s);\n" name (String.concat ", " c_params);
3126
3127       (* Free up arguments. *)
3128       List.iter (
3129         function
3130         | AHive | ANode _ | AValue _
3131         | AString _ | AStringNullable _
3132         | AOpenFlags | AUnusedFlags -> ()
3133         | ASetValues ->
3134             pr "  free (values.values);\n"
3135         | ASetValue -> ()
3136       ) (snd style);
3137
3138       (* Check for errors from C library. *)
3139       pr "  if (r == %s) {\n" error_code;
3140       pr "    PyErr_SetString (PyExc_RuntimeError,\n";
3141       pr "                     strerror (errno));\n";
3142       pr "    return NULL;\n";
3143       pr "  }\n";
3144       pr "\n";
3145
3146       (* Convert return value to Python. *)
3147       (match fst style with
3148        | RErr
3149        | RErrDispose ->
3150            pr "  Py_INCREF (Py_None);\n";
3151            pr "  py_r = Py_None;\n"
3152        | RHive ->
3153            pr "  py_r = put_handle (r);\n"
3154        | RSize
3155        | RNode ->
3156            pr "  py_r = PyLong_FromLongLong (r);\n"
3157        | RNodeNotFound ->
3158            pr "  if (r)\n";
3159            pr "    py_r = PyLong_FromLongLong (r);\n";
3160            pr "  else {\n";
3161            pr "    Py_INCREF (Py_None);\n";
3162            pr "    py_r = Py_None;\n";
3163            pr "  }\n";
3164        | RNodeList
3165        | RValueList ->
3166            pr "  py_r = put_node_list (r);\n";
3167            pr "  free (r);\n"
3168        | RValue ->
3169            pr "  py_r = PyLong_FromLongLong (r);\n"
3170        | RString ->
3171            pr "#ifdef HAVE_PYSTRING_ASSTRING\n";
3172            pr "  py_r = PyString_FromString (r);\n";
3173            pr "#else\n";
3174            pr "  py_r = PyUnicode_FromString (r);\n";
3175            pr "#endif\n";
3176            pr "  free (r);"
3177        | RStringList ->
3178            pr "  py_r = put_string_list (r);\n";
3179            pr "  free_strings (r);\n"
3180        | RLenType ->
3181            pr "  py_r = put_len_type (len, t);\n"
3182        | RLenValue ->
3183            pr "  py_r = put_len_val (len, r);\n"
3184        | RLenTypeVal ->
3185            pr "  py_r = put_val_type (r, len, t);\n";
3186            pr "  free (r);\n"
3187        | RInt32 ->
3188            pr "  py_r = PyLong_FromLong ((long) r);\n"
3189        | RInt64 ->
3190            pr "  py_r = PyLong_FromLongLong (r);\n"
3191       );
3192       pr "  return py_r;\n";
3193       pr "}\n";
3194       pr "\n"
3195   ) functions;
3196
3197   (* Table of functions. *)
3198   pr "static PyMethodDef methods[] = {\n";
3199   List.iter (
3200     fun (name, _, _, _) ->
3201       pr "  { (char *) \"%s\", py_hivex_%s, METH_VARARGS, NULL },\n"
3202         name name
3203   ) functions;
3204   pr "  { NULL, NULL, 0, NULL }\n";
3205   pr "};\n";
3206   pr "\n";
3207
3208   (* Init function. *)
3209   pr "\
3210 #if PY_MAJOR_VERSION >= 3
3211 static struct PyModuleDef moduledef = {
3212   PyModuleDef_HEAD_INIT,
3213   \"libhivexmod\",       /* m_name */
3214   \"hivex module\",      /* m_doc */
3215   -1,                    /* m_size */
3216   methods,               /* m_methods */
3217   NULL,                  /* m_reload */
3218   NULL,                  /* m_traverse */
3219   NULL,                  /* m_clear */
3220   NULL,                  /* m_free */
3221 };
3222 #endif
3223
3224 static PyObject *
3225 moduleinit (void)
3226 {
3227   PyObject *m;
3228
3229 #if PY_MAJOR_VERSION >= 3
3230   m = PyModule_Create (&moduledef);
3231 #else
3232   m = Py_InitModule ((char *) \"libhivexmod\", methods);
3233 #endif
3234
3235   return m; /* m might be NULL if module init failed */
3236 }
3237
3238 #if PY_MAJOR_VERSION >= 3
3239 PyMODINIT_FUNC
3240 PyInit_libhivexmod (void)
3241 {
3242   return moduleinit ();
3243 }
3244 #else
3245 void
3246 initlibhivexmod (void)
3247 {
3248   (void) moduleinit ();
3249 }
3250 #endif
3251 "
3252
3253 and generate_python_py () =
3254   generate_header HashStyle LGPLv2plus;
3255
3256   pr "\
3257 \"\"\"Python bindings for hivex
3258
3259 import hivex
3260 h = hivex.Hivex (filename)
3261
3262 The hivex module provides Python bindings to the hivex API for
3263 examining and modifying Windows Registry 'hive' files.
3264
3265 Read the hivex(3) man page to find out how to use the API.
3266 \"\"\"
3267
3268 import libhivexmod
3269
3270 class Hivex:
3271     \"\"\"Instances of this class are hivex API handles.\"\"\"
3272
3273     def __init__ (self, filename";
3274
3275   List.iter (
3276     fun (_, flag, _) -> pr ", %s = False" (String.lowercase flag)
3277   ) open_flags;
3278
3279   pr "):
3280         \"\"\"Create a new hivex handle.\"\"\"
3281         flags = 0
3282 ";
3283
3284   List.iter (
3285     fun (n, flag, description) ->
3286       pr "        # %s\n" description;
3287       pr "        if %s: flags += %d\n" (String.lowercase flag) n
3288   ) open_flags;
3289
3290   pr "        self._o = libhivexmod.open (filename, flags)
3291
3292     def __del__ (self):
3293         libhivexmod.close (self._o)
3294
3295 ";
3296
3297   List.iter (
3298     fun (name, style, shortdesc, _) ->
3299       (* The close and open calls are handled specially above. *)
3300       if fst style <> RErrDispose && List.hd (snd style) = AHive then (
3301         let args = List.tl (snd style) in
3302         let args = List.filter (
3303           function AOpenFlags | AUnusedFlags -> false
3304           | _ -> true
3305         ) args in
3306
3307         pr "    def %s (self" name;
3308         List.iter (fun arg -> pr ", %s" (name_of_argt arg)) args;
3309         pr "):\n";
3310         pr "        \"\"\"%s\"\"\"\n" shortdesc;
3311         pr "        return libhivexmod.%s (self._o" name;
3312         List.iter (
3313           fun arg ->
3314             pr ", ";
3315             match arg with
3316             | AHive -> assert false
3317             | ANode n | AValue n
3318             | AString n | AStringNullable n -> pr "%s" n
3319             | AOpenFlags
3320             | AUnusedFlags -> assert false
3321             | ASetValues -> pr "values"
3322             | ASetValue -> pr "val"
3323         ) args;
3324         pr ")\n";
3325         pr "\n"
3326       )
3327   ) functions
3328
3329 and generate_ruby_c () =
3330   generate_header CStyle LGPLv2plus;
3331
3332   pr "\
3333 #include <stdio.h>
3334 #include <stdlib.h>
3335 #include <stdint.h>
3336
3337 #include <ruby.h>
3338
3339 #include \"hivex.h\"
3340
3341 #include \"extconf.h\"
3342
3343 /* For Ruby < 1.9 */
3344 #ifndef RARRAY_LEN
3345 #define RARRAY_LEN(r) (RARRAY((r))->len)
3346 #endif
3347
3348 #ifndef RSTRING_LEN
3349 #define RSTRING_LEN(r) (RSTRING((r))->len)
3350 #endif
3351
3352 #ifndef RSTRING_PTR
3353 #define RSTRING_PTR(r) (RSTRING((r))->ptr)
3354 #endif
3355
3356 static VALUE m_hivex;                   /* hivex module */
3357 static VALUE c_hivex;                   /* hive_h handle */
3358 static VALUE e_Error;                   /* used for all errors */
3359
3360 static void
3361 ruby_hivex_free (void *hvp)
3362 {
3363   hive_h *h = hvp;
3364
3365   if (h)
3366     hivex_close (h);
3367 }
3368
3369 static void
3370 get_value (VALUE valv, hive_set_value *val)
3371 {
3372   VALUE key = rb_hash_lookup (valv, ID2SYM (rb_intern (\"key\")));
3373   VALUE type = rb_hash_lookup (valv, ID2SYM (rb_intern (\"type\")));
3374   VALUE value = rb_hash_lookup (valv, ID2SYM (rb_intern (\"value\")));
3375
3376   val->key = StringValueCStr (key);
3377   val->t = NUM2ULL (type);
3378   val->len = RSTRING_LEN (value);
3379   val->value = RSTRING_PTR (value);
3380 }
3381
3382 static hive_set_value *
3383 get_values (VALUE valuesv, size_t *nr_values)
3384 {
3385   size_t i;
3386   hive_set_value *ret;
3387
3388   *nr_values = RARRAY_LEN (valuesv);
3389   ret = malloc (sizeof (*ret) * *nr_values);
3390   if (ret == NULL)
3391     abort ();
3392
3393   for (i = 0; i < *nr_values; ++i) {
3394     VALUE v = rb_ary_entry (valuesv, i);
3395     get_value (v, &ret[i]);
3396   }
3397
3398   return ret;
3399 }
3400
3401 ";
3402
3403   List.iter (
3404     fun (name, (ret, args), shortdesc, longdesc) ->
3405       let () =
3406         (* Generate rdoc. *)
3407         let doc = replace_str longdesc "C<hivex_" "C<h." in
3408         let doc = pod2text ~width:60 name doc in
3409         let doc = String.concat "\n * " doc in
3410         let doc = trim doc in
3411
3412         let call, args =
3413           match args with
3414           | AHive :: args -> "h." ^ name, args
3415           | args -> "Hivex::" ^ name, args in
3416         let args = filter_map (
3417           function
3418           | AUnusedFlags -> None
3419           | args -> Some (name_of_argt args)
3420         ) args in
3421         let args = String.concat ", " args in
3422
3423         let ret =
3424           match ret with
3425           | RErr | RErrDispose -> "nil"
3426           | RHive -> "Hivex::Hivex"
3427           | RSize | RNode | RNodeNotFound -> "integer"
3428           | RNodeList -> "list"
3429           | RValue -> "integer"
3430           | RValueList -> "list"
3431           | RString -> "string"
3432           | RStringList -> "list"
3433           | RLenType -> "hash"
3434           | RLenValue -> "integer"
3435           | RLenTypeVal -> "hash"
3436           | RInt32 -> "integer"
3437           | RInt64 -> "integer" in
3438
3439         pr "\
3440 /*
3441  * call-seq:
3442  *   %s(%s) -> %s
3443  *
3444  * %s
3445  *
3446  * %s
3447  *
3448  * (For the C API documentation for this function, see
3449  * +hivex_%s+[http://libguestfs.org/hivex.3.html#hivex_%s]).
3450  */
3451 " call args ret shortdesc doc name name in
3452
3453       (* Generate the function. *)
3454       pr "static VALUE\n";
3455       pr "ruby_hivex_%s (" name;
3456
3457       let () =
3458         (* If the first argument is not AHive, then this is a module-level
3459          * function, and Ruby passes an implicit module argument which we
3460          * must ignore.  Otherwise the first argument is the hive handle.
3461          *)
3462         let args =
3463           match args with
3464           | AHive :: args -> pr "VALUE hv"; args
3465           | args -> pr "VALUE modulev"; args in
3466         List.iter (
3467           function
3468           | AUnusedFlags -> ()
3469           | arg ->
3470             pr ", VALUE %sv" (name_of_argt arg)
3471         ) args;
3472         pr ")\n" in
3473
3474       pr "{\n";
3475
3476       List.iter (
3477         function
3478         | AHive ->
3479           pr "  hive_h *h;\n";
3480           pr "  Data_Get_Struct (hv, hive_h, h);\n";
3481           pr "  if (!h)\n";
3482           pr "    rb_raise (rb_eArgError, \"%%s: used handle after closing it\",\n";
3483           pr "              \"%s\");\n" name;
3484         | ANode n ->
3485           pr "  hive_node_h %s = NUM2ULL (%sv);\n" n n
3486         | AValue n ->
3487           pr "  hive_value_h %s = NUM2ULL (%sv);\n" n n
3488         | AString n ->
3489           pr "  const char *%s = StringValueCStr (%sv);\n" n n;
3490         | AStringNullable n ->
3491           pr "  const char *%s =\n" n;
3492           pr "    !NIL_P (%sv) ? StringValueCStr (%sv) : NULL;\n" n n
3493         | AOpenFlags ->
3494           pr "  int flags = 0;\n";
3495           List.iter (
3496             fun (n, flag, _) ->
3497               pr "  if (RTEST (rb_hash_lookup (flagsv, ID2SYM (rb_intern (\"%s\")))))\n"
3498                 (String.lowercase flag);
3499               pr "    flags += %d;\n" n
3500           ) open_flags
3501         | AUnusedFlags -> ()
3502         | ASetValues ->
3503           pr "  size_t nr_values;\n";
3504           pr "  hive_set_value *values;\n";
3505           pr "  values = get_values (valuesv, &nr_values);\n"
3506         | ASetValue ->
3507           pr "  hive_set_value val;\n";
3508           pr "  get_value (valv, &val);\n"
3509       ) args;
3510       pr "\n";
3511
3512       let error_code =
3513         match ret with
3514         | RErr -> pr "  int r;\n"; "-1"
3515         | RErrDispose -> pr "  int r;\n"; "-1"
3516         | RHive -> pr "  hive_h *r;\n"; "NULL"
3517         | RSize -> pr "  size_t r;\n"; "0"
3518         | RNode -> pr "  hive_node_h r;\n"; "0"
3519         | RNodeNotFound ->
3520             pr "  errno = 0;\n";
3521             pr "  hive_node_h r;\n";
3522             "0 && errno != 0"
3523         | RNodeList -> pr "  hive_node_h *r;\n"; "NULL"
3524         | RValue -> pr "  hive_value_h r;\n"; "0"
3525         | RValueList -> pr "  hive_value_h *r;\n"; "NULL"
3526         | RString -> pr "  char *r;\n"; "NULL"
3527         | RStringList -> pr "  char **r;\n"; "NULL"
3528         | RLenType ->
3529             pr "  int r;\n";
3530             pr "  size_t len;\n";
3531             pr "  hive_type t;\n";
3532             "-1"
3533         | RLenValue ->
3534             pr "  errno = 0;\n";
3535             pr "  hive_value_h r;\n";
3536             pr "  size_t len;\n";
3537             "0 && errno != 0"
3538         | RLenTypeVal ->
3539             pr "  char *r;\n";
3540             pr "  size_t len;\n";
3541             pr "  hive_type t;\n";
3542             "NULL"
3543         | RInt32 ->
3544             pr "  errno = 0;\n";
3545             pr "  int32_t r;\n";
3546             "-1 && errno != 0"
3547         | RInt64 ->
3548             pr "  errno = 0;\n";
3549             pr "  int64_t r;\n";
3550             "-1 && errno != 0" in
3551       pr "\n";
3552
3553       let c_params =
3554         List.map (function
3555                   | ASetValues -> ["nr_values"; "values"]
3556                   | ASetValue -> ["&val"]
3557                   | AUnusedFlags -> ["0"]
3558                   | arg -> [name_of_argt arg]) args in
3559       let c_params =
3560         match ret with
3561         | RLenType | RLenTypeVal -> c_params @ [["&t"; "&len"]]
3562         | RLenValue -> c_params @ [["&len"]]
3563         | _ -> c_params in
3564       let c_params = List.concat c_params in
3565
3566       pr "  r = hivex_%s (%s" name (List.hd c_params);
3567       List.iter (pr ", %s") (List.tl c_params);
3568       pr ");\n";
3569       pr "\n";
3570
3571       (* Dispose of the hive handle (even if hivex_close returns error). *)
3572       (match ret with
3573        | RErrDispose ->
3574            pr "  /* So we don't double-free in the finalizer. */\n";
3575            pr "  DATA_PTR (hv) = NULL;\n";
3576            pr "\n";
3577        | _ -> ()
3578       );
3579
3580       List.iter (
3581         function
3582         | AHive
3583         | ANode _
3584         | AValue _
3585         | AString _
3586         | AStringNullable _
3587         | AOpenFlags
3588         | AUnusedFlags -> ()
3589         | ASetValues ->
3590           pr "  free (values);\n"
3591         | ASetValue -> ()
3592       ) args;
3593
3594       (* Check for errors from C library. *)
3595       pr "  if (r == %s)\n" error_code;
3596       pr "    rb_raise (e_Error, \"%%s\", strerror (errno));\n";
3597       pr "\n";
3598
3599       (match ret with
3600       | RErr | RErrDispose ->
3601         pr "  return Qnil;\n"
3602       | RHive ->
3603         pr "  return Data_Wrap_Struct (c_hivex, NULL, ruby_hivex_free, r);\n"
3604       | RSize
3605       | RNode
3606       | RValue
3607       | RInt64 ->
3608         pr "  return ULL2NUM (r);\n"
3609       | RInt32 ->
3610         pr "  return INT2NUM (r);\n"
3611       | RNodeNotFound ->
3612         pr "  if (r)\n";
3613         pr "    return ULL2NUM (r);\n";
3614         pr "  else\n";
3615         pr "    return Qnil;\n"
3616       | RNodeList
3617       | RValueList ->
3618         pr "  size_t i, len = 0;\n";
3619         pr "  for (i = 0; r[i] != 0; ++i) len++;\n";
3620         pr "  VALUE rv = rb_ary_new2 (len);\n";
3621         pr "  for (i = 0; r[i] != 0; ++i)\n";
3622         pr "    rb_ary_push (rv, ULL2NUM (r[i]));\n";
3623         pr "  free (r);\n";
3624         pr "  return rv;\n"
3625       | RString ->
3626         pr "  VALUE rv = rb_str_new2 (r);\n";
3627         pr "  free (r);\n";
3628         pr "  return rv;\n"
3629       | RStringList ->
3630         pr "  size_t i, len = 0;\n";
3631         pr "  for (i = 0; r[i] != NULL; ++i) len++;\n";
3632         pr "  VALUE rv = rb_ary_new2 (len);\n";
3633         pr "  for (i = 0; r[i] != NULL; ++i) {\n";
3634         pr "    rb_ary_push (rv, rb_str_new2 (r[i]));\n";
3635         pr "    free (r[i]);\n";
3636         pr "  }\n";
3637         pr "  free (r);\n";
3638         pr "  return rv;\n"
3639       | RLenType ->
3640         pr "  VALUE rv = rb_hash_new ();\n";
3641         pr "  rb_hash_aset (rv, ID2SYM (rb_intern (\"len\")), INT2NUM (len));\n";
3642         pr "  rb_hash_aset (rv, ID2SYM (rb_intern (\"type\")), INT2NUM (t));\n";
3643         pr "  return rv;\n"
3644       | RLenValue ->
3645         pr "  VALUE rv = rb_hash_new ();\n";
3646         pr "  rb_hash_aset (rv, ID2SYM (rb_intern (\"len\")), INT2NUM (len));\n";
3647         pr "  rb_hash_aset (rv, ID2SYM (rb_intern (\"off\")), ULL2NUM (r));\n";
3648         pr "  return rv;\n"
3649       | RLenTypeVal ->
3650         pr "  VALUE rv = rb_hash_new ();\n";
3651         pr "  rb_hash_aset (rv, ID2SYM (rb_intern (\"len\")), INT2NUM (len));\n";
3652         pr "  rb_hash_aset (rv, ID2SYM (rb_intern (\"type\")), INT2NUM (t));\n";
3653         pr "  rb_hash_aset (rv, ID2SYM (rb_intern (\"value\")), rb_str_new (r, len));\n";
3654         pr "  free (r);\n";
3655         pr "  return rv;\n"
3656       );
3657
3658       pr "}\n";
3659       pr "\n"
3660   ) functions;
3661
3662   pr "\
3663 /* Initialize the module. */
3664 void Init__hivex ()
3665 {
3666   m_hivex = rb_define_module (\"Hivex\");
3667   c_hivex = rb_define_class_under (m_hivex, \"Hivex\", rb_cObject);
3668   e_Error = rb_define_class_under (m_hivex, \"Error\", rb_eStandardError);
3669
3670   /* XXX How to pass arguments? */
3671 #if 0
3672 #ifdef HAVE_RB_DEFINE_ALLOC_FUNC
3673   rb_define_alloc_func (c_hivex, ruby_hivex_open);
3674 #endif
3675 #endif
3676
3677 ";
3678
3679   (* Methods. *)
3680   List.iter (
3681     fun (name, (_, args), _, _) ->
3682       let args = List.filter (
3683         function
3684         | AUnusedFlags -> false
3685         | _ -> true
3686       ) args in
3687       let nr_args = List.length args in
3688       match args with
3689       | AHive :: _ ->
3690         pr "  rb_define_method (c_hivex, \"%s\",\n" name;
3691         pr "                    ruby_hivex_%s, %d);\n" name (nr_args-1)
3692       | args -> (* class function *)
3693         pr "  rb_define_module_function (m_hivex, \"%s\",\n" name;
3694         pr "                             ruby_hivex_%s, %d);\n" name nr_args
3695   ) functions;
3696
3697   pr "}\n"
3698
3699 let output_to filename k =
3700   let filename_new = filename ^ ".new" in
3701   chan := open_out filename_new;
3702   k ();
3703   close_out !chan;
3704   chan := Pervasives.stdout;
3705
3706   (* Is the new file different from the current file? *)
3707   if Sys.file_exists filename && files_equal filename filename_new then
3708     unlink filename_new                 (* same, so skip it *)
3709   else (
3710     (* different, overwrite old one *)
3711     (try chmod filename 0o644 with Unix_error _ -> ());
3712     rename filename_new filename;
3713     chmod filename 0o444;
3714     printf "written %s\n%!" filename;
3715   )
3716
3717 let perror msg = function
3718   | Unix_error (err, _, _) ->
3719       eprintf "%s: %s\n" msg (error_message err)
3720   | exn ->
3721       eprintf "%s: %s\n" msg (Printexc.to_string exn)
3722
3723 (* Main program. *)
3724 let () =
3725   let lock_fd =
3726     try openfile "configure.ac" [O_RDWR] 0
3727     with
3728     | Unix_error (ENOENT, _, _) ->
3729         eprintf "\
3730 You are probably running this from the wrong directory.
3731 Run it from the top source directory using the command
3732   generator/generator.ml
3733 ";
3734         exit 1
3735     | exn ->
3736         perror "open: configure.ac" exn;
3737         exit 1 in
3738
3739   (* Acquire a lock so parallel builds won't try to run the generator
3740    * twice at the same time.  Subsequent builds will wait for the first
3741    * one to finish.  Note the lock is released implicitly when the
3742    * program exits.
3743    *)
3744   (try lockf lock_fd F_LOCK 1
3745    with exn ->
3746      perror "lock: configure.ac" exn;
3747      exit 1);
3748
3749   check_functions ();
3750
3751   output_to "lib/hivex.h" generate_c_header;
3752   output_to "lib/hivex.pod" generate_c_pod;
3753
3754   output_to "lib/hivex.syms" generate_linker_script;
3755
3756   output_to "ocaml/hivex.mli" generate_ocaml_interface;
3757   output_to "ocaml/hivex.ml" generate_ocaml_implementation;
3758   output_to "ocaml/hivex_c.c" generate_ocaml_c;
3759
3760   output_to "perl/lib/Win/Hivex.pm" generate_perl_pm;
3761   output_to "perl/Hivex.xs" generate_perl_xs;
3762
3763   output_to "python/hivex.py" generate_python_py;
3764   output_to "python/hivex-py.c" generate_python_c;
3765
3766   output_to "ruby/ext/hivex/_hivex.c" generate_ruby_c;
3767
3768   (* Always generate this file last, and unconditionally.  It's used
3769    * by the Makefile to know when we must re-run the generator.
3770    *)
3771   let chan = open_out "generator/stamp-generator" in
3772   fprintf chan "1\n";
3773   close_out chan;
3774
3775   printf "generated %d lines of code\n" !lines