1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
|
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
|
