From 7483c7454538584a3dbe4582096f058e6e877df6 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Fri, 6 Mar 2015 15:35:46 +0000 Subject: [PATCH] Add a binding for virDomainCreateXML. This is more modern than the ancient virDomainCreateLinux API, and crucially allows you to pass flags such as AUTODESTROY. --- configure.ac | 2 +- libvirt/generator.pl | 23 +++++++++++++++++++++-- libvirt/libvirt.ml | 19 ++++++++++++++++++- libvirt/libvirt.mli | 13 +++++++++++-- libvirt/libvirt_c.c | 25 ++++++++++++++++++++++++- 5 files changed, 75 insertions(+), 7 deletions(-) diff --git a/configure.ac b/configure.ac index b7544b4..a719fb3 100644 --- a/configure.ac +++ b/configure.ac @@ -1,5 +1,5 @@ # ocaml-libvirt -# Copyright (C) 2007-2008 Red Hat Inc., Richard W.M. Jones +# Copyright (C) 2007-2015 Red Hat Inc., Richard W.M. Jones # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Lesser General Public diff --git a/libvirt/generator.pl b/libvirt/generator.pl index 8229ad1..421592b 100755 --- a/libvirt/generator.pl +++ b/libvirt/generator.pl @@ -1,7 +1,7 @@ #!/usr/bin/perl -w # # OCaml bindings for libvirt. -# (C) Copyright 2007-2008 Richard W.M. Jones, Red Hat Inc. +# (C) Copyright 2007-2015 Richard W.M. Jones, Red Hat Inc. # http://libvirt.org/ # # This library is free software; you can redistribute it and/or @@ -63,6 +63,7 @@ my @functions = ( sig => "conn, int : unit" }, { name => "virDomainCreateLinux", sig => "conn, string, 0U : dom" }, + { name => "virDomainCreateXML", sig => "conn, string, unsigned : dom" }, { name => "virDomainFree", sig => "dom : free" }, { name => "virDomainDestroy", sig => "dom : free" }, { name => "virDomainLookupByName", sig => "conn, string : dom" }, @@ -198,7 +199,7 @@ print F <<'END'; */ /* OCaml bindings for libvirt. - * (C) Copyright 2007-2008 Richard W.M. Jones, Red Hat Inc. + * (C) Copyright 2007-2015 Richard W.M. Jones, Red Hat Inc. * http://libvirt.org/ * * This library is free software; you can redistribute it and/or @@ -310,6 +311,8 @@ sub gen_arg_names ( "$1v", "strv" ) } elsif ($sig =~ /^(\w+), string, 0U? : (\w+)$/) { ( "$1v", "strv" ) + } elsif ($sig =~ /^(\w+), string, unsigned : (\w+)$/) { + ( "$1v", "strv", "uv" ) } elsif ($sig =~ /^(\w+), u?int : (\w+)$/) { ( "$1v", "iv" ) } elsif ($sig =~ /^(\w+), uuid : (\w+)$/) { @@ -632,6 +635,22 @@ sub gen_c_code CAMLreturn (rv); " + } elsif ($sig =~ /^(\w+), string, unsigned : (\w+)$/) { + my $c_ret_type = short_name_to_c_type ($2); + "\ + CAMLlocal1 (rv); + " . gen_unpack_args ($1) . " + char *str = String_val (strv); + unsigned int u = Int_val (uv); + $c_ret_type r; + + NONBLOCKING (r = $c_name ($1, str, u)); + CHECK_ERROR (!r, conn, \"$c_name\"); + + " . gen_pack_result ($2) . " + + CAMLreturn (rv); +" } elsif ($sig =~ /^(\w+), (u?)int : unit$/) { my $unsigned = $2 eq "u" ? "unsigned " : ""; "\ diff --git a/libvirt/libvirt.ml b/libvirt/libvirt.ml index 9c9368a..1be023d 100644 --- a/libvirt/libvirt.ml +++ b/libvirt/libvirt.ml @@ -1,5 +1,5 @@ (* OCaml bindings for libvirt. - (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. + (C) Copyright 2007-2015 Richard W.M. Jones, Red Hat Inc. http://libvirt.org/ This library is free software; you can redistribute it and/or @@ -337,6 +337,20 @@ struct cpu : int; } + type domain_create_flag = + | START_PAUSED + | START_AUTODESTROY + | START_BYPASS_CACHE + | START_FORCE_BOOT + | START_VALIDATE + let rec int_of_domain_create_flags = function + | [] -> 0 + | START_PAUSED :: flags -> 1 lor int_of_domain_create_flags flags + | START_AUTODESTROY :: flags -> 2 lor int_of_domain_create_flags flags + | START_BYPASS_CACHE :: flags -> 4 lor int_of_domain_create_flags flags + | START_FORCE_BOOT :: flags -> 8 lor int_of_domain_create_flags flags + | START_VALIDATE :: flags -> 16 lor int_of_domain_create_flags flags + type sched_param = string * sched_param_value and sched_param_value = | SchedFieldInt32 of int32 | SchedFieldUInt32 of int32 @@ -385,6 +399,9 @@ struct let max_peek _ = 65536 external create_linux : [>`W] Connect.t -> xml -> rw t = "ocaml_libvirt_domain_create_linux" + external _create_xml : [>`W] Connect.t -> xml -> int -> rw t = "ocaml_libvirt_domain_create_xml" + let create_xml conn xml flags = + _create_xml conn xml (int_of_domain_create_flags flags) external lookup_by_id : 'a Connect.t -> int -> 'a t = "ocaml_libvirt_domain_lookup_by_id" external lookup_by_uuid : 'a Connect.t -> uuid -> 'a t = "ocaml_libvirt_domain_lookup_by_uuid" external lookup_by_uuid_string : 'a Connect.t -> string -> 'a t = "ocaml_libvirt_domain_lookup_by_uuid_string" diff --git a/libvirt/libvirt.mli b/libvirt/libvirt.mli index 36cd113..8cfcae2 100644 --- a/libvirt/libvirt.mli +++ b/libvirt/libvirt.mli @@ -1,5 +1,5 @@ (** OCaml bindings for libvirt. *) -(* (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. +(* (C) Copyright 2007-2015 Richard W.M. Jones, Red Hat Inc. http://libvirt.org/ This library is free software; you can redistribute it and/or @@ -430,6 +430,13 @@ sig cpu : int; (** real CPU number, -1 if offline *) } + type domain_create_flag = + | START_PAUSED (** Launch guest in paused state *) + | START_AUTODESTROY (** Automatically kill guest on close *) + | START_BYPASS_CACHE (** Avoid filesystem cache pollution *) + | START_FORCE_BOOT (** Discard any managed save *) + | START_VALIDATE (** Validate XML against schema *) + type sched_param = string * sched_param_value and sched_param_value = | SchedFieldInt32 of int32 | SchedFieldUInt32 of int32 @@ -478,8 +485,10 @@ sig val create_linux : [>`W] Connect.t -> xml -> rw t (** Create a new guest domain (not necessarily a Linux one) - from the given XML. + from the given XML. Use {!create_xml} instead. *) + val create_xml : [>`W] Connect.t -> xml -> domain_create_flag list -> rw t + (** Create a new guest domain from the given XML. *) val lookup_by_id : 'a Connect.t -> int -> 'a t (** Lookup a domain by ID. *) val lookup_by_uuid : 'a Connect.t -> uuid -> 'a t diff --git a/libvirt/libvirt_c.c b/libvirt/libvirt_c.c index 71e6f61..6e56682 100644 --- a/libvirt/libvirt_c.c +++ b/libvirt/libvirt_c.c @@ -6,7 +6,7 @@ */ /* OCaml bindings for libvirt. - * (C) Copyright 2007-2008 Richard W.M. Jones, Red Hat Inc. + * (C) Copyright 2007-2015 Richard W.M. Jones, Red Hat Inc. * http://libvirt.org/ * * This library is free software; you can redistribute it and/or @@ -525,6 +525,29 @@ ocaml_libvirt_domain_create_linux (value connv, value strv) CAMLreturn (rv); } +/* Automatically generated binding for virDomainCreateXML. + * In generator.pl this function has signature "conn, string, unsigned : dom". + */ + +CAMLprim value +ocaml_libvirt_domain_create_xml (value connv, value strv, value uv) +{ + CAMLparam3 (connv, strv, uv); + + CAMLlocal1 (rv); + virConnectPtr conn = Connect_val (connv); + char *str = String_val (strv); + unsigned int u = Int_val (uv); + virDomainPtr r; + + NONBLOCKING (r = virDomainCreateXML (conn, str, u)); + CHECK_ERROR (!r, conn, "virDomainCreateXML"); + + rv = Val_domain (r, connv); + + CAMLreturn (rv); +} + /* Automatically generated binding for virDomainFree. * In generator.pl this function has signature "dom : free". */ -- 2.3.1