From 7483c7454538584a3dbe4582096f058e6e877df6 Mon Sep 17 00:00:00 2001

From: "Richard W.M. Jones" <rjones@redhat.com>

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