From 5e00037f5c7309a316275e44ba1e58c2630d0438 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Fri, 26 Feb 2010 11:29:09 +0000 Subject: [PATCH] generator: Perl bindings. This also adds a small test suite for the Perl bindings. --- generator/generator.ml | 620 ++++++++++++++++++++++++++++++++++++++++++++-- perl/t/005-pod.t | 24 ++ perl/t/006-pod-coverage.t | 24 ++ perl/t/010-load.t | 24 ++ perl/t/020-open.t | 27 ++ perl/t/021-close.t | 31 +++ perl/t/200-write.t | 49 ++++ perl/typemap | 8 +- 8 files changed, 784 insertions(+), 23 deletions(-) create mode 100644 perl/t/005-pod.t create mode 100644 perl/t/006-pod-coverage.t create mode 100644 perl/t/010-load.t create mode 100644 perl/t/020-open.t create mode 100644 perl/t/021-close.t create mode 100644 perl/t/200-write.t diff --git a/generator/generator.ml b/generator/generator.ml index 8696dec..830597b 100755 --- a/generator/generator.ml +++ b/generator/generator.ml @@ -251,7 +251,8 @@ C, C or C."; "return value as multiple strings", "\ If this value is a multiple-string, return the strings reencoded -as UTF-8 (as a NULL-terminated array of C strings). This only +as UTF-8 (in C, as a NULL-terminated array of C strings, in other +language bindings, as a list of strings). This only works for values which have type C."; "value_dword", (RInt32, [AHive; AValue "val"]), @@ -271,14 +272,14 @@ works for values which have type C."; "\ Commit (write) any changes which have been made. -C is the new file to write. If C is NULL then we -overwrite the original file (ie. the file name that was passed to -C). C is not used, always pass 0. +C is the new file to write. If C is null/undefined +then we overwrite the original file (ie. the file name that was passed to +C). Note this does not close the hive handle. You can perform further operations on the hive after committing, including making more -modifications. If you no longer wish to use the hive, call -C after this."; +modifications. If you no longer wish to use the hive, then you +should close the handle after committing."; "node_add_child", (RNode, [AHive; ANode "parent"; AString "name"]), "add child node", @@ -302,18 +303,11 @@ subnodes become invalid. You cannot delete the root node."; "node_set_values", (RErr, [AHive; ANode "node"; ASetValues; AUnusedFlags]), "set (key, value) pairs at a node", "\ -This call can be used to set all the (key, value) pairs stored in C. +This call can be used to set all the (key, value) pairs +stored in C. Note that this library does not offer +a way to modify just a single key at a node. -C is the node to modify. C is an array of (key, value) -pairs. There should be C elements in this array. C -is not used, always pass 0. - -Any existing values stored at the node are discarded, and their -C handles become invalid. Thus you can remove all -values stored at C by passing C. - -Note that this library does not offer a way to modify just a single -key at a node. We don't implement a way to do this efficiently."; +C is the node to modify."; ] (* Used to memoize the result of pod2text. *) @@ -931,6 +925,18 @@ here. Often it's not documented at all. pr "\n"; pr "%s\n" longdesc; pr "\n"; + + if List.mem AUnusedFlags (snd style) then + pr "The flags parameter is unused. Always pass 0.\n\n"; + + if List.mem ASetValues (snd style) then + pr "C is an array of (key, value) pairs. There +should be C elements in this array. + +Any existing values stored at the node are discarded, and their +C handles become invalid. Thus you can remove all +values stored at C by passing C.\n\n"; + (match fst style with | RErr -> pr "\ @@ -1852,10 +1858,586 @@ Val_hiveh (hive_h *h) " max_hive_type and generate_perl_pm () = - generate_header HashStyle LGPLv2plus + generate_header HashStyle LGPLv2plus; + + pr "\ +=pod + +=head1 NAME + +Win::Hivex - Perl bindings for reading and writing Windows Registry hive files + +=head1 SYNOPSIS + + use Win::Hivex; + + $h = Win::Hivex->open ('SOFTWARE'); + $root_node = $h->root (); + print $h->node_name ($root_node); + +=head1 DESCRIPTION + +The C module provides a Perl XS binding to the +L API for reading and writing Windows Registry binary +hive files. + +=head1 ERRORS + +All errors turn into calls to C (see L). + +=head1 METHODS + +=over 4 + +=cut + +package Win::Hivex; + +use strict; +use warnings; + +require XSLoader; +XSLoader::load ('Win::Hivex'); + +=item open + + $h = Win::Hivex::open ($filename,"; + + List.iter ( + fun (_, flag, _) -> + pr "\n [%s => 1,]" (String.lowercase flag) + ) open_flags; + + pr ") + +Open a Windows Registry binary hive file. + +The C and C flags enable different levels of +debugging messages. + +The C flag is required if you will be modifying the +hive file (see L). + +This function returns a hive handle. The hive handle is +closed automatically when its reference count drops to 0. + +=cut + +sub open { + my $proto = shift; + my $class = ref ($proto) || $proto; + my $filename = shift; + my %%flags = @_; + my $flags = 0; + +"; + + List.iter ( + fun (n, flag, description) -> + pr " # %s\n" description; + pr " $flags += %d if $flags{%s};\n" n (String.lowercase flag) + ) open_flags; + + pr "\ + + my $self = Win::Hivex::_open ($filename, $flags); + bless $self, $class; + return $self; +} + +"; + + List.iter ( + fun (name, style, _, longdesc) -> + (* The close call isn't explicit in Perl: handles are closed + * when their reference count drops to 0. + * + * The open call is coded specially in Perl. + * + * Therefore we don't generate prototypes for these two calls: + *) + if fst style <> RErrDispose && List.hd (snd style) = AHive then ( + let longdesc = replace_str longdesc "C () + | RNode -> + pr "\ +This returns a node handle.\n\n" + | RNodeNotFound -> + pr "\ +This returns a node handle, or C if the node was not found.\n\n" + | RNodeList -> + pr "\ +This returns a list of node handles.\n\n" + | RValue -> + pr "\ +This returns a value handle.\n\n" + | RValueList -> + pr "\ +This returns a list of value handles.\n\n" + ); + + if List.mem ASetValues (snd style) then + pr "C<@values> is an array of (keys, value) pairs. +Each element should be a hashref containing C, C (type) +and C. + +Any existing values stored at the node are discarded, and their +C handles become invalid. Thus you can remove all +values stored at C by passing C<@values = []>.\n\n" + ) + ) functions; + + pr "\ +=cut + +1; + +=back + +=head1 COPYRIGHT + +Copyright (C) %s Red Hat Inc. + +=head1 LICENSE + +Please see the file COPYING.LIB for the full license. + +=head1 SEE ALSO + +L, +L, +L, +L. + +=cut +" copyright_years + +and generate_perl_prototype name style = + (* Return type. *) + (match fst style with + | RErr + | RErrDispose -> () + | RHive -> pr "$h = " + | RNode + | RNodeNotFound -> pr "$node = " + | RNodeList -> pr "@nodes = " + | RValue -> pr "$value = " + | RValueList -> pr "@values = " + | RString -> pr "$string = " + | RStringList -> pr "@strings = " + | RLenType -> pr "($type, $len) = " + | RLenTypeVal -> pr "($type, $data) = " + | RInt32 -> pr "$int32 = " + | RInt64 -> pr "$int64 = " + ); + + let args = List.tl (snd style) in + + (* AUnusedFlags is dropped in the bindings. *) + let args = List.filter ((<>) AUnusedFlags) args in + + pr "$h->%s (" name; + + let comma = ref false in + List.iter ( + fun arg -> + if !comma then pr ", "; comma := true; + match arg with + | AHive -> pr "$h" + | ANode n + | AValue n + | AString n -> pr "$%s" n + | AStringNullable n -> pr "[$%s|undef]" n + | AOpenFlags -> pr "[flags]" + | AUnusedFlags -> assert false + | ASetValues -> pr "\\@values" + ) args; + + pr ")" and generate_perl_xs () = - generate_header CStyle LGPLv2plus + generate_header CStyle LGPLv2plus; + + pr "\ +#include \"EXTERN.h\" +#include \"perl.h\" +#include \"XSUB.h\" + +#include +#include + +#ifndef PRId64 +#define PRId64 \"lld\" +#endif + +static SV * +my_newSVll(long long val) { +#ifdef USE_64_BIT_ALL + return newSViv(val); +#else + char buf[100]; + int len; + len = snprintf(buf, 100, \"%%\" PRId64, val); + return newSVpv(buf, len); +#endif +} + +#ifndef PRIu64 +#define PRIu64 \"llu\" +#endif + +#if 0 +static SV * +my_newSVull(unsigned long long val) { +#ifdef USE_64_BIT_ALL + return newSVuv(val); +#else + char buf[100]; + int len; + len = snprintf(buf, 100, \"%%\" PRIu64, val); + return newSVpv(buf, len); +#endif +} +#endif + +#if 0 +/* http://www.perlmonks.org/?node_id=680842 */ +static char ** +XS_unpack_charPtrPtr (SV *arg) { + char **ret; + AV *av; + I32 i; + + if (!arg || !SvOK (arg) || !SvROK (arg) || SvTYPE (SvRV (arg)) != SVt_PVAV) + croak (\"array reference expected\"); + + av = (AV *)SvRV (arg); + ret = malloc ((av_len (av) + 1 + 1) * sizeof (char *)); + if (!ret) + croak (\"malloc failed\"); + + for (i = 0; i <= av_len (av); i++) { + SV **elem = av_fetch (av, i, 0); + + if (!elem || !*elem) + croak (\"missing element in list\"); + + ret[i] = SvPV_nolen (*elem); + } + + ret[i] = NULL; + + return ret; +} +#endif + +/* Handle set_values parameter. */ +typedef struct pl_set_values { + size_t nr_values; + hive_set_value *values; +} pl_set_values; + +static pl_set_values +unpack_pl_set_values (SV *sv) +{ + pl_set_values ret; + AV *av; + I32 i; + + if (!sv || !SvOK (sv) || !SvROK (sv) || SvTYPE (SvRV (sv)) != SVt_PVAV) + croak (\"array reference expected\"); + + av = (AV *)SvRV(sv); + ret.nr_values = av_len (av) + 1; + ret.values = malloc (ret.nr_values * sizeof (hive_set_value)); + if (!ret.values) + croak (\"malloc failed\"); + + for (i = 0; i <= av_len (av); i++) { + SV **hvp = av_fetch (av, i, 0); + + if (!hvp || !*hvp || !SvROK (*hvp) || SvTYPE (SvRV (*hvp)) != SVt_PVHV) + croak (\"missing element in list or not a hash ref\"); + + HV *hv = (HV *)SvRV(*hvp); + + SV **svp; + svp = hv_fetch (hv, \"key\", 3, 0); + if (!svp || !*svp) + croak (\"missing 'key' in hash\"); + ret.values[i].key = SvPV_nolen (*svp); + + svp = hv_fetch (hv, \"t\", 1, 0); + if (!svp || !*svp) + croak (\"missing 't' in hash\"); + ret.values[i].t = SvIV (*svp); + + svp = hv_fetch (hv, \"value\", 5, 0); + if (!svp || !*svp) + croak (\"missing 'value' in hash\"); + ret.values[i].value = SvPV (*svp, ret.values[i].len); + } + + return ret; +} + +MODULE = Win::Hivex PACKAGE = Win::Hivex + +PROTOTYPES: ENABLE + +hive_h * +_open (filename, flags) + char *filename; + int flags; + CODE: + RETVAL = hivex_open (filename, flags); + if (!RETVAL) + croak (\"hivex_open: %%s: %%s\", filename, strerror (errno)); + OUTPUT: + RETVAL + +void +DESTROY (h) + hive_h *h; + PPCODE: + if (hivex_close (h) == -1) + croak (\"hivex_close: %%s\", strerror (errno)); + +"; + + List.iter ( + fun (name, style, _, longdesc) -> + (* The close and open calls are handled specially above. *) + if fst style <> RErrDispose && List.hd (snd style) = AHive then ( + (match fst style with + | RErr -> pr "void\n" + | RErrDispose -> failwith "perl bindings cannot handle a call which disposes of the handle" + | RHive -> failwith "perl bindings cannot handle a call which returns a handle" + | RNode + | RNodeNotFound + | RValue + | RString -> pr "SV *\n" + | RNodeList + | RValueList + | RStringList + | RLenType + | RLenTypeVal -> pr "void\n" + | RInt32 -> pr "SV *\n" + | RInt64 -> pr "SV *\n" + ); + + (* Call and arguments. *) + let perl_params = + filter_map (function + | AUnusedFlags -> None + | arg -> Some (name_of_argt arg)) (snd style) in + + let c_params = + List.map (function + | AUnusedFlags -> "0" + | ASetValues -> "values.nr_values, values.values" + | arg -> name_of_argt arg) (snd style) in + + pr "%s (%s)\n" name (String.concat ", " perl_params); + iteri ( + fun i -> + function + | AHive -> + pr " hive_h *h;\n" + | ANode n + | AValue n -> + pr " int %s;\n" n + | AString n -> + pr " char *%s;\n" n + | AStringNullable n -> + (* http://www.perlmonks.org/?node_id=554277 *) + pr " char *%s = SvOK(ST(%d)) ? SvPV_nolen(ST(%d)) : NULL;\n" n i i + | AOpenFlags -> + pr " int flags;\n" + | AUnusedFlags -> () + | ASetValues -> + pr " pl_set_values values = unpack_pl_set_values (ST(%d));\n" i + ) (snd style); + + let free_args () = + List.iter ( + function + | ASetValues -> + pr " free (values.values);\n" + | AHive | ANode _ | AValue _ | AString _ | AStringNullable _ + | AOpenFlags | AUnusedFlags -> () + ) (snd style) + in + + (* Code. *) + (match fst style with + | RErr -> + pr "PREINIT:\n"; + pr " int r;\n"; + pr " PPCODE:\n"; + pr " r = hivex_%s (%s);\n" + name (String.concat ", " c_params); + free_args (); + pr " if (r == -1)\n"; + pr " croak (\"%%s: %%s\", \"%s\", strerror (errno));\n" + name; + + | RErrDispose -> assert false + | RHive -> assert false + + | RInt32 + | RNode + | RValue -> + pr "PREINIT:\n"; + pr " /* hive_node_h = hive_value_h = size_t so we cheat\n"; + pr " here to simplify the generator */\n"; + pr " size_t r;\n"; + pr " CODE:\n"; + pr " r = hivex_%s (%s);\n" + name (String.concat ", " c_params); + free_args (); + pr " if (r == 0)\n"; + pr " croak (\"%%s: %%s\", \"%s\", strerror (errno));\n" + name; + pr " RETVAL = newSViv (r);\n"; + pr " OUTPUT:\n"; + pr " RETVAL\n" + + | RNodeNotFound -> + pr "PREINIT:\n"; + pr " hive_node_h r;\n"; + pr " CODE:\n"; + pr " errno = 0;\n"; + pr " r = hivex_%s (%s);\n" + name (String.concat ", " c_params); + free_args (); + pr " if (r == 0 && errno != 0)\n"; + pr " croak (\"%%s: %%s\", \"%s\", strerror (errno));\n" + name; + pr " if (r == 0)\n"; + pr " RETVAL = &PL_sv_undef;\n"; + pr " else\n"; + pr " RETVAL = newSViv (r);\n"; + pr " OUTPUT:\n"; + pr " RETVAL\n" + + | RString -> + pr "PREINIT:\n"; + pr " char *r;\n"; + pr " CODE:\n"; + pr " r = hivex_%s (%s);\n" + name (String.concat ", " c_params); + free_args (); + pr " if (r == NULL)\n"; + pr " croak (\"%%s: %%s\", \"%s\", strerror (errno));\n" + name; + pr " RETVAL = newSVpv (r, 0);\n"; + pr " free (r);\n"; + pr " OUTPUT:\n"; + pr " RETVAL\n" + + | RNodeList + | RValueList -> + pr "PREINIT:\n"; + pr " size_t *r;\n"; + pr " int i, n;\n"; + pr " PPCODE:\n"; + pr " r = hivex_%s (%s);\n" + name (String.concat ", " c_params); + free_args (); + pr " if (r == NULL)\n"; + pr " croak (\"%%s: %%s\", \"%s\", strerror (errno));\n" + name; + pr " for (n = 0; r[n] != 0; ++n) /**/;\n"; + pr " EXTEND (SP, n);\n"; + pr " for (i = 0; i < n; ++i)\n"; + pr " PUSHs (sv_2mortal (newSViv (r[i])));\n"; + pr " free (r);\n"; + + | RStringList -> + pr "PREINIT:\n"; + pr " char **r;\n"; + pr " int i, n;\n"; + pr " PPCODE:\n"; + pr " r = hivex_%s (%s);\n" + name (String.concat ", " c_params); + free_args (); + pr " if (r == NULL)\n"; + pr " croak (\"%%s: %%s\", \"%s\", strerror (errno));\n" + name; + pr " for (n = 0; r[n] != NULL; ++n) /**/;\n"; + pr " EXTEND (SP, n);\n"; + pr " for (i = 0; i < n; ++i) {\n"; + pr " PUSHs (sv_2mortal (newSVpv (r[i], 0)));\n"; + pr " free (r[i]);\n"; + pr " }\n"; + pr " free (r);\n"; + + | RLenType -> + pr "PREINIT:\n"; + pr " int r;\n"; + pr " size_t len;\n"; + pr " hive_type type;\n"; + pr " PPCODE:\n"; + pr " r = hivex_%s (%s, &len, &type);\n" + name (String.concat ", " c_params); + free_args (); + pr " if (r == -1)\n"; + pr " croak (\"%%s: %%s\", \"%s\", strerror (errno));\n" + name; + pr " EXTEND (SP, 2);\n"; + pr " PUSHs (sv_2mortal (newSViv (type)));\n"; + pr " PUSHs (sv_2mortal (newSViv (len)));\n"; + + | RLenTypeVal -> + pr "PREINIT:\n"; + pr " char *r;\n"; + pr " size_t len;\n"; + pr " hive_type type;\n"; + pr " PPCODE:\n"; + pr " r = hivex_%s (%s, &len, &type);\n" + name (String.concat ", " c_params); + free_args (); + pr " if (r == NULL)\n"; + pr " croak (\"%%s: %%s\", \"%s\", strerror (errno));\n" + name; + pr " EXTEND (SP, 2);\n"; + pr " PUSHs (sv_2mortal (newSViv (type)));\n"; + pr " PUSHs (sv_2mortal (newSVpv (r, len)));\n"; + pr " free (r);\n"; + + | RInt64 -> + pr "PREINIT:\n"; + pr " int64_t r;\n"; + pr " CODE:\n"; + pr " errno = 0;\n"; + pr " r = hivex_%s (%s);\n" + name (String.concat ", " c_params); + free_args (); + pr " if (r == -1 && errno != 0)\n"; + pr " croak (\"%%s: %%s\", \"%s\", strerror (errno));\n" + name; + pr " RETVAL = my_newSVll (r);\n"; + pr " OUTPUT:\n"; + pr " RETVAL\n" + ); + pr "\n" + ) + ) functions and generate_python_py () = generate_header HashStyle LGPLv2plus diff --git a/perl/t/005-pod.t b/perl/t/005-pod.t new file mode 100644 index 0000000..8fef583 --- /dev/null +++ b/perl/t/005-pod.t @@ -0,0 +1,24 @@ +# hivex Perl bindings -*- perl -*- +# Copyright (C) 2010 Red Hat Inc. +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +use Test::More; +use strict; +use warnings; + +eval "use Test::Pod 1.00"; +plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; +all_pod_files_ok (); diff --git a/perl/t/006-pod-coverage.t b/perl/t/006-pod-coverage.t new file mode 100644 index 0000000..00c13c6 --- /dev/null +++ b/perl/t/006-pod-coverage.t @@ -0,0 +1,24 @@ +# hivex Perl bindings -*- perl -*- +# Copyright (C) 2009 Red Hat Inc. +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +use Test::More; +use strict; +use warnings; + +eval "use Test::Pod::Coverage 1.00"; +plan skip_all => "Test::Pod::Coverage 1.00 required for testing POD" if $@; +all_pod_coverage_ok ({also_private => [ qr/^test0.*/ ]}); diff --git a/perl/t/010-load.t b/perl/t/010-load.t new file mode 100644 index 0000000..9abcdc8 --- /dev/null +++ b/perl/t/010-load.t @@ -0,0 +1,24 @@ +# hivex Perl bindings -*- perl -*- +# Copyright (C) 2010 Red Hat Inc. +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +use strict; +use warnings; +use Test::More tests => 1; + +BEGIN { + use_ok ("Win::Hivex"); +} diff --git a/perl/t/020-open.t b/perl/t/020-open.t new file mode 100644 index 0000000..b3c58f0 --- /dev/null +++ b/perl/t/020-open.t @@ -0,0 +1,27 @@ +# hivex Perl bindings -*- perl -*- +# Copyright (C) 2010 Red Hat Inc. +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +use strict; +use warnings; +use Test::More tests => 1; + +use Win::Hivex; + +my $srcdir = $ENV{srcdir} || "."; + +my $h = Win::Hivex->open ("$srcdir/../images/minimal"); +ok ($h); diff --git a/perl/t/021-close.t b/perl/t/021-close.t new file mode 100644 index 0000000..f6388fc --- /dev/null +++ b/perl/t/021-close.t @@ -0,0 +1,31 @@ +# hivex Perl bindings -*- perl -*- +# Copyright (C) 2010 Red Hat Inc. +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +use strict; +use warnings; +use Test::More tests => 2; + +use Win::Hivex; + +my $srcdir = $ENV{srcdir} || "."; + +# Put it in a block so the handle gets destroyed as well. +{ + my $h = Win::Hivex->open ("$srcdir/../images/minimal"); + ok ($h); +} +ok (1); diff --git a/perl/t/200-write.t b/perl/t/200-write.t new file mode 100644 index 0000000..e7fd570 --- /dev/null +++ b/perl/t/200-write.t @@ -0,0 +1,49 @@ +# hivex Perl bindings -*- perl -*- +# Copyright (C) 2010 Red Hat Inc. +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +use strict; +use warnings; +use Test::More tests => 6; + +use Win::Hivex; + +my $srcdir = $ENV{srcdir} || "."; + +my $h = Win::Hivex->open ("$srcdir/../images/minimal", write => 1); +ok ($h); + +my $root = $h->root (); +ok ($root); + +$h->node_add_child ($root, "A"); +ok (1); + +$h->node_add_child ($root, "B"); +ok (1); + +my $b = $h->node_get_child ($root, "B"); +ok ($b); + +my $values = [ + { key => "Key1", t => 3, value => "ABC" }, + { key => "Key2", t => 3, value => "DEF" } + ]; +$h->node_set_values ($b, $values); +ok (1); + +# don't commit because that would overwrite the original file +# $h->commit (); diff --git a/perl/typemap b/perl/typemap index 752ca0d..2cc5e0c 100644 --- a/perl/typemap +++ b/perl/typemap @@ -1,11 +1,11 @@ TYPEMAP char * T_PV const char * T_PV -guestfs_h * O_OBJECT_guestfs_h +hive_h * O_OBJECT_hive_h int64_t T_IV INPUT -O_OBJECT_guestfs_h +O_OBJECT_hive_h if (sv_isobject ($arg) && SvTYPE (SvRV ($arg)) == SVt_PVMG) $var = ($type) SvIV ((SV *) SvRV ($arg)); else { @@ -14,5 +14,5 @@ O_OBJECT_guestfs_h } OUTPUT -O_OBJECT_guestfs_h - sv_setref_pv ($arg, "Sys::Guestfs", (void *) $var); +O_OBJECT_hive_h + sv_setref_pv ($arg, "Win::Hivex", (void *) $var); -- 1.8.3.1