From 3b39f65412f3583fb4a3c7c833da09e7c22a64a9 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Thu, 1 Jan 1970 00:00:00 +0000 Subject: [PATCH] Add support for virDomainBlockPeek, virDomainMemoryPeek and remove the deprecated conn/dom/net fields in virterror. --- config.h.in | 6 +++ configure.ac | 4 +- libvirt/libvirt.ml | 13 +++--- libvirt/libvirt.mli | 30 +++++++----- libvirt/libvirt_c_epilogue.c | 100 +++------------------------------------ libvirt/libvirt_c_oneoffs.c | 108 +++++++++++++++++++++++++++++++++++++++++++ libvirt/libvirt_c_prologue.c | 16 ------- 7 files changed, 148 insertions(+), 129 deletions(-) diff --git a/config.h.in b/config.h.in index 886a316..68f6bbf 100644 --- a/config.h.in +++ b/config.h.in @@ -50,6 +50,9 @@ /* Define to 1 if you have the `virConnectNumOfStoragePools' function. */ #undef HAVE_VIRCONNECTNUMOFSTORAGEPOOLS +/* Define to 1 if you have the `virDomainBlockPeek' function. */ +#undef HAVE_VIRDOMAINBLOCKPEEK + /* Define to 1 if you have the `virDomainBlockStats' function. */ #undef HAVE_VIRDOMAINBLOCKSTATS @@ -62,6 +65,9 @@ /* Define to 1 if you have the `virDomainInterfaceStats' function. */ #undef HAVE_VIRDOMAININTERFACESTATS +/* Define to 1 if you have the `virDomainMemoryPeek' function. */ +#undef HAVE_VIRDOMAINMEMORYPEEK + /* Define to 1 if you have the `virDomainMigrate' function. */ #undef HAVE_VIRDOMAINMIGRATE diff --git a/configure.ac b/configure.ac index 6d68217..fc95682 100644 --- a/configure.ac +++ b/configure.ac @@ -17,7 +17,7 @@ dnl Process this file with autoconf to produce a configure script. -AC_INIT(ocaml-libvirt,0.4.2.1) +AC_INIT(ocaml-libvirt,0.4.2.2) dnl Check for basic C environment. AC_PROG_CC @@ -123,6 +123,8 @@ AC_CHECK_FUNCS([virConnectGetHostname \ virStorageVolGetInfo \ virStorageVolGetXMLDesc \ virStorageVolGetPath \ + virDomainBlockPeek \ + virDomainMemoryPeek \ ]) # This jobs API was never published and is due to get overhauled diff --git a/libvirt/libvirt.ml b/libvirt/libvirt.ml index aefc6c4..044d4a2 100644 --- a/libvirt/libvirt.ml +++ b/libvirt/libvirt.ml @@ -130,6 +130,8 @@ struct type migrate_flag = Live + type memory_flag = Virtual + type block_stats = { rd_req : int64; rd_bytes : int64; @@ -195,6 +197,8 @@ struct external migrate : [>`W] t -> [>`W] Connect.t -> migrate_flag list -> ?dname:string -> ?uri:string -> ?bandwidth:int -> unit -> rw t = "ocaml_libvirt_domain_migrate_bytecode" "ocaml_libvirt_domain_migrate_native" external block_stats : [>`R] t -> string -> block_stats = "ocaml_libvirt_domain_block_stats" external interface_stats : [>`R] t -> string -> interface_stats = "ocaml_libvirt_domain_interface_stats" + external block_peek : [>`R] t -> string -> int64 -> int -> string -> int -> unit = "ocaml_libvirt_domain_block_peek_bytecode" "ocaml_libvirt_domain_block_peek_native" + external memory_peek : [>`R] t -> memory_flag -> int64 -> int -> string -> int -> unit = "ocaml_libvirt_domain_memory_peek_bytecode" "ocaml_libvirt_domain_memory_peek_native" external const : [>`R] t -> ro t = "%identity" end @@ -477,14 +481,11 @@ struct domain : domain; message : string option; level : level; - conn : ro Connect.t option; - dom : ro Domain.t option; str1 : string option; str2 : string option; str3 : string option; int1 : int32; int2 : int32; - net : ro Network.t option; } let to_string { code = code; domain = domain; message = message } = @@ -503,10 +504,10 @@ struct external reset_last_conn_error : [>`R] Connect.t -> unit = "ocaml_libvirt_virterror_reset_last_conn_error" let no_error () = - { code = VIR_ERR_OK; domain = VIR_FROM_NONE; message = None; - level = VIR_ERR_NONE; conn = None; dom = None; + { code = VIR_ERR_OK; domain = VIR_FROM_NONE; + message = None; level = VIR_ERR_NONE; str1 = None; str2 = None; str3 = None; - int1 = 0_l; int2 = 0_l; net = None } + int1 = 0_l; int2 = 0_l } end exception Virterror of Virterror.t diff --git a/libvirt/libvirt.mli b/libvirt/libvirt.mli index af372af..f08158d 100644 --- a/libvirt/libvirt.mli +++ b/libvirt/libvirt.mli @@ -126,9 +126,8 @@ v} {3 General safety issues} Memory allocation / automatic garbage collection of all libvirt - objects should be completely safe (except in the specific - virterror case noted below). If you find any safety issues or if your - pure OCaml program ever segfaults, please contact the author. + objects should be completely safe. If you find any safety issues + or if your pure OCaml program ever segfaults, please contact the author. You can force a libvirt object to be freed early by calling the [close] function on the object. This shouldn't affect @@ -143,12 +142,6 @@ v} Thus domain objects can through odd exceptions at any time. This is just the nature of virtualisation. - Virterror has a specific design error which means that the - objects embedded in a virterror exception message are only - valid as long as the connection handle is still open. This - is a design flaw in the C code of libvirt and we cannot fix - or work around it in the OCaml bindings. - {3 Backwards and forwards compatibility} OCaml-libvirt is backwards and forwards compatible with @@ -425,6 +418,8 @@ sig type migrate_flag = Live + type memory_flag = Virtual + type block_stats = { rd_req : int64; rd_bytes : int64; @@ -566,6 +561,20 @@ sig val interface_stats : [>`R] t -> string -> interface_stats (** Returns network interface stats. *) + val block_peek : [>`R] t -> string -> int64 -> int -> string -> int -> unit + (** [block_peek dom path offset size buf boff] reads [size] bytes at + [offset] in the domain's [path] block device. + + If successful then the data is written into [buf] starting + at offset [boff], for [size] bytes. *) + val memory_peek : [>`R] t -> memory_flag -> int64 -> int -> string -> int -> + unit + (** [memory_peek dom Virtual offset size] reads [size] bytes + at [offset] in the domain's virtual memory. + + If successful then the data is written into [buf] starting + at offset [boff], for [size] bytes. *) + external const : [>`R] t -> ro t = "%identity" (** [const dom] turns a read/write domain handle into a read-only domain handle. Note that the opposite operation is impossible. @@ -938,14 +947,11 @@ sig domain : domain; (** Origin of the error. *) message : string option; (** Human-readable message. *) level : level; (** Error or warning. *) - conn : ro Connect.t option; (** Associated connection. *) - dom : ro Domain.t option; (** Associated domain. *) str1 : string option; (** Informational string. *) str2 : string option; (** Informational string. *) str3 : string option; (** Informational string. *) int1 : int32; (** Informational integer. *) int2 : int32; (** Informational integer. *) - net : ro Network.t option; (** Associated network. *) } (** An error object. *) diff --git a/libvirt/libvirt_c_epilogue.c b/libvirt/libvirt_c_epilogue.c index 78bd23e..9d2b0fa 100644 --- a/libvirt/libvirt_c_epilogue.c +++ b/libvirt/libvirt_c_epilogue.c @@ -170,47 +170,21 @@ Val_virterror (virErrorPtr err) CAMLparam0 (); CAMLlocal3 (rv, connv, optv); - rv = caml_alloc (12, 0); + rv = caml_alloc (9, 0); Store_field (rv, 0, Val_err_number (err->code)); Store_field (rv, 1, Val_err_domain (err->domain)); Store_field (rv, 2, Val_opt (err->message, (Val_ptr_t) caml_copy_string)); Store_field (rv, 3, Val_err_level (err->level)); - /* conn, dom and net fields, all optional */ - if (err->conn) { - connv = Val_connect_no_finalize (err->conn); - optv = caml_alloc (1, 0); - Store_field (optv, 0, connv); - Store_field (rv, 4, optv); /* Some conn */ - - if (err->dom) { - optv = caml_alloc (1, 0); - Store_field (optv, 0, Val_domain_no_finalize (err->dom, connv)); - Store_field (rv, 5, optv); /* Some (dom, conn) */ - } - else - Store_field (rv, 5, Val_int (0)); /* None */ - if (err->net) { - optv = caml_alloc (1, 0); - Store_field (optv, 0, Val_network_no_finalize (err->net, connv)); - Store_field (rv, 11, optv); /* Some (net, conn) */ - } else - Store_field (rv, 11, Val_int (0)); /* None */ - } else { - Store_field (rv, 4, Val_int (0)); /* None */ - Store_field (rv, 5, Val_int (0)); /* None */ - Store_field (rv, 11, Val_int (0)); /* None */ - } - - Store_field (rv, 6, + Store_field (rv, 4, Val_opt (err->str1, (Val_ptr_t) caml_copy_string)); - Store_field (rv, 7, + Store_field (rv, 5, Val_opt (err->str2, (Val_ptr_t) caml_copy_string)); - Store_field (rv, 8, + Store_field (rv, 6, Val_opt (err->str3, (Val_ptr_t) caml_copy_string)); - Store_field (rv, 9, caml_copy_int32 (err->int1)); - Store_field (rv, 10, caml_copy_int32 (err->int2)); + Store_field (rv, 7, caml_copy_int32 (err->int1)); + Store_field (rv, 8, caml_copy_int32 (err->int2)); CAMLreturn (rv); } @@ -361,39 +335,6 @@ Val_jb (virJobPtr jb) } #endif -/* No-finalize versions of Val_connect, Val_dom, Val_net ONLY for use - * by virterror wrappers. - */ -static value -Val_connect_no_finalize (virConnectPtr conn) -{ - CAMLparam0 (); - CAMLlocal1 (rv); - rv = caml_alloc (1, Abstract_tag); - Store_field (rv, 0, (value) conn); - CAMLreturn (rv); -} - -static value -Val_dom_no_finalize (virDomainPtr dom) -{ - CAMLparam0 (); - CAMLlocal1 (rv); - rv = caml_alloc (1, Abstract_tag); - Store_field (rv, 0, (value) dom); - CAMLreturn (rv); -} - -static value -Val_net_no_finalize (virNetworkPtr net) -{ - CAMLparam0 (); - CAMLlocal1 (rv); - rv = caml_alloc (1, Abstract_tag); - Store_field (rv, 0, (value) net); - CAMLreturn (rv); -} - /* This wraps up the (dom, conn) pair (Domain.t). */ static value Val_domain (virDomainPtr dom, value connv) @@ -470,35 +411,6 @@ Val_job (virJobPtr jb, value connv) } #endif -/* No-finalize versions of Val_domain, Val_network ONLY for use by - * virterror wrappers. - */ -static value -Val_domain_no_finalize (virDomainPtr dom, value connv) -{ - CAMLparam1 (connv); - CAMLlocal2 (rv, v); - - rv = caml_alloc_tuple (2); - v = Val_dom_no_finalize (dom); - Store_field (rv, 0, v); - Store_field (rv, 1, connv); - CAMLreturn (rv); -} - -static value -Val_network_no_finalize (virNetworkPtr net, value connv) -{ - CAMLparam1 (connv); - CAMLlocal2 (rv, v); - - rv = caml_alloc_tuple (2); - v = Val_net_no_finalize (net); - Store_field (rv, 0, v); - Store_field (rv, 1, connv); - CAMLreturn (rv); -} - static void conn_finalize (value connv) { diff --git a/libvirt/libvirt_c_oneoffs.c b/libvirt/libvirt_c_oneoffs.c index 5df783e..14045f6 100644 --- a/libvirt/libvirt_c_oneoffs.c +++ b/libvirt/libvirt_c_oneoffs.c @@ -661,6 +661,114 @@ ocaml_libvirt_domain_interface_stats (value domv, value pathv) } #ifdef HAVE_WEAK_SYMBOLS +#ifdef HAVE_VIRDOMAINBLOCKPEEK +extern int virDomainBlockPeek (virDomainPtr domain, + const char *path, + unsigned long long offset, + size_t size, + void *buffer, + unsigned int flags) + __attribute__((weak)); +#endif +#endif + +CAMLprim value +ocaml_libvirt_domain_block_peek_native (value domv, value pathv, value offsetv, value sizev, value bufferv, value boffv) +{ +#ifdef HAVE_VIRDOMAINBLOCKPEEK + CAMLparam5 (domv, pathv, offsetv, sizev, bufferv); + CAMLxparam1 (boffv); + virDomainPtr dom = Domain_val (domv); + virConnectPtr conn = Connect_domv (domv); + const char *path = String_val (pathv); + unsigned long long offset = Int64_val (offsetv); + size_t size = Int_val (sizev); + char *buffer = String_val (bufferv); + int boff = Int_val (boffv); + int r; + + /* Check that the return buffer is big enough. */ + if (caml_string_length (bufferv) < boff + size) + caml_failwith ("virDomainBlockPeek: return buffer too short"); + + WEAK_SYMBOL_CHECK (virDomainBlockPeek); + /* NB. not NONBLOCKING because buffer might move (XXX) */ + r = virDomainBlockPeek (dom, path, offset, size, buffer+boff, 0); + CHECK_ERROR (r == -1, conn, "virDomainBlockPeek"); + + CAMLreturn (Val_unit); + +#else /* virDomainBlockPeek not supported */ + not_supported ("virDomainBlockPeek"); +#endif +} + +CAMLprim value +ocaml_libvirt_domain_block_peek_bytecode (value *argv, int argn) +{ + return ocaml_libvirt_domain_block_peek_native (argv[0], argv[1], argv[2], + argv[3], argv[4], argv[5]); +} + +#ifdef HAVE_WEAK_SYMBOLS +#ifdef HAVE_VIRDOMAINMEMORYPEEK +extern int virDomainMemoryPeek (virDomainPtr domain, + unsigned long long offset, + size_t size, + void *buffer, + unsigned int flags) + __attribute__((weak)); +#endif +#endif + +CAMLprim value +ocaml_libvirt_domain_memory_peek_native (value domv, int flagsv, value offsetv, value sizev, value bufferv, value boffv) +{ +#ifdef HAVE_VIRDOMAINMEMORYPEEK + CAMLparam5 (domv, flagsv, offsetv, sizev, bufferv); + CAMLxparam1 (boffv); + CAMLlocal1 (flagv); + virDomainPtr dom = Domain_val (domv); + virConnectPtr conn = Connect_domv (domv); + int flags = 0; + unsigned long long offset = Int64_val (offsetv); + size_t size = Int_val (sizev); + char *buffer = String_val (bufferv); + int boff = Int_val (boffv); + int r; + + /* Check that the return buffer is big enough. */ + if (caml_string_length (bufferv) < boff + size) + caml_failwith ("virDomainBlockPeek: return buffer too short"); + + /* Do flags. */ + for (; flagsv != Val_int (0); flagsv = Field (flagsv, 1)) + { + flagv = Field (flagsv, 0); + if (flagv == Int_val (0)) + flags |= VIR_MEMORY_VIRTUAL; + } + + WEAK_SYMBOL_CHECK (virDomainMemoryPeek); + /* NB. not NONBLOCKING because buffer might move (XXX) */ + r = virDomainMemoryPeek (dom, offset, size, buffer+boff, flags); + CHECK_ERROR (r == -1, conn, "virDomainMemoryPeek"); + + CAMLreturn (Val_unit); + +#else /* virDomainMemoryPeek not supported */ + not_supported ("virDomainMemoryPeek"); +#endif +} + +CAMLprim value +ocaml_libvirt_domain_memory_peek_bytecode (value *argv, int argn) +{ + return ocaml_libvirt_domain_memory_peek_native (argv[0], argv[1], argv[2], + argv[3], argv[4], argv[5]); +} + +#ifdef HAVE_WEAK_SYMBOLS #ifdef HAVE_VIRSTORAGEPOOLGETINFO extern int virStoragePoolGetInfo(virStoragePoolPtr pool, virStoragePoolInfoPtr info) __attribute__((weak)); diff --git a/libvirt/libvirt_c_prologue.c b/libvirt/libvirt_c_prologue.c index 7fe9714..451cc7c 100644 --- a/libvirt/libvirt_c_prologue.c +++ b/libvirt/libvirt_c_prologue.c @@ -104,13 +104,6 @@ static value Val_virterror (virErrorPtr err); * wrappers store domains (and networks) as explicit (dom, conn) * pairs. * - * Further complication with virterror / exceptions: Virterror gives - * us virConnectPtr, virDomainPtr, virNetworkPtr pointers. If we - * follow standard practice and wrap these up in blocks with - * finalizers then we'll end up double-freeing (in particular, calling - * virConnectClose at the wrong time). So for virterror, we have - * "special" wrapper functions (Val_connect_no_finalize, etc.). - * * Update 2008/01: Storage pools and volumes work the same way as * domains and networks. And jobs. */ @@ -143,11 +136,6 @@ static value Val_vol (virStorageVolPtr vol); static value Val_jb (virJobPtr jb); #endif -/* ONLY for use by virterror wrappers. */ -static value Val_connect_no_finalize (virConnectPtr conn); -static value Val_dom_no_finalize (virDomainPtr dom); -static value Val_net_no_finalize (virNetworkPtr net); - /* Domains and networks are stored as pairs (dom/net, conn), so have * some convenience functions for unwrapping and wrapping them. */ @@ -185,7 +173,3 @@ static value Val_volume (virStorageVolPtr vol, value connv); #ifdef HAVE_VIRJOBPTR static value Val_job (virJobPtr jb, value connv); #endif - -/* ONLY for use by virterror wrappers. */ -static value Val_domain_no_finalize (virDomainPtr dom, value connv); -static value Val_network_no_finalize (virNetworkPtr net, value connv); -- 1.8.3.1