[PATCH 13 of 15] libxl: ocaml: propagate the libxl return error code in exceptions

[Ian Campbell <ian.campbell@citrix.com>]

# HG changeset patch
# User Ian Campbell <ijc@hellion.org.uk>
# Date 1353432141 0
# Node ID c8d22bfef298ce525c98b5a3f0c394068ab01572
# Parent  e4525795eac22c7d199ceae8714e95ed660a00c4
libxl: ocaml: propagate the libxl return error code in exceptions

Signed-off-by: Ian Campbell <ian.campbell@citrix.com>

diff -r e4525795eac2 -r c8d22bfef298 tools/ocaml/libs/xl/genwrap.py
--- a/tools/ocaml/libs/xl/genwrap.py	Tue Nov 20 17:22:21 2012 +0000
+++ b/tools/ocaml/libs/xl/genwrap.py	Tue Nov 20 17:22:21 2012 +0000
@@ -228,7 +228,7 @@ def c_val(ty, c, o, indent="", parent = 
         for e in ty.values:
             s += "    case %d: *%s = %s; break;\n" % (n, c, e.name)
             n += 1
-        s += "    default: failwith_xl(\"cannot convert value to %s\"); break;\n" % ty.typename
+        s += "    default: failwith_xl(ERROR_FAIL, \"cannot convert value to %s\"); break;\n" % ty.typename
         s += "}"
     elif isinstance(ty, idl.KeyedUnion):
         s += "{\n"
@@ -241,7 +241,7 @@ def c_val(ty, c, o, indent="", parent = 
                                                     parent + ty.keyvar.name,
                                                     f.enumname)
             n += 1
-        s += "\t\t    default: failwith_xl(\"variant handling bug %s%s (long)\"); break;\n" % (parent, ty.keyvar.name)        
+        s += "\t\t    default: failwith_xl(ERROR_FAIL, \"variant handling bug %s%s (long)\"); break;\n" % (parent, ty.keyvar.name)        
         s += "\t\t}\n"
         s += "\t} else {\n"
         s += "\t\t/* Is block... */\n"
@@ -257,7 +257,7 @@ def c_val(ty, c, o, indent="", parent = 
                 s += "%s" % c_val(f.type, fexpr, o, indent=indent+"\t\t        ")
                 s += "break;\n"
             n += 1
-        s += "\t\t    default: failwith_xl(\"variant handling bug %s%s (block)\"); break;\n" % (parent, ty.keyvar.name)
+        s += "\t\t    default: failwith_xl(ERROR_FAIL, \"variant handling bug %s%s (block)\"); break;\n" % (parent, ty.keyvar.name)
         s += "\t\t}\n"
         s += "\t}\n"
         s += "}"
@@ -326,7 +326,7 @@ def ocaml_Val(ty, o, c, indent="", paren
         for e in ty.values:
             s += "    case %s: %s = Int_val(%d); break;\n" % (e.name, o, n)
             n += 1
-        s += "    default: failwith_xl(\"cannot convert value from %s\"); break;\n" % ty.typename
+        s += "    default: failwith_xl(ERROR_FAIL, \"cannot convert value from %s\"); break;\n" % ty.typename
         s += "}"
     elif isinstance(ty, idl.KeyedUnion):
         n = 0
@@ -347,7 +347,7 @@ def ocaml_Val(ty, o, c, indent="", paren
                 #s += "\t        %s = caml_alloc(%d,%d);\n" % (o,len(f.type.fields),n)
             s += "\t        break;\n"
             n += 1
-        s += "\t    default: failwith_xl(\"cannot convert value from %s\"); break;\n" % ty.typename
+        s += "\t    default: failwith_xl(ERROR_FAIL, \"cannot convert value from %s\"); break;\n" % ty.typename
         s += "\t}"
     elif isinstance(ty,idl.Aggregate) and (parent is None or ty.rawname is None):
         s += "{\n"
diff -r e4525795eac2 -r c8d22bfef298 tools/ocaml/libs/xl/xenlight.ml.in
--- a/tools/ocaml/libs/xl/xenlight.ml.in	Tue Nov 20 17:22:21 2012 +0000
+++ b/tools/ocaml/libs/xl/xenlight.ml.in	Tue Nov 20 17:22:21 2012 +0000
@@ -15,7 +15,47 @@
 
 open Xentoollog
 
-exception Error of string
+type error = 
+    Nonspecific |
+    Version |
+    Fail |
+    Ni |
+    Nomem |
+    Inval |
+    Badfail |
+    Guest_Timedout |
+    Timedout |
+    Noparavirt |
+    Not_Ready |
+    Osevent_Reg_Fail |
+    Bufferfull |
+    Unknown_Child
+
+let string_of_error error =
+  match error with
+  | Nonspecific -> "Non specific"
+  | Version -> "Version"
+  | Fail -> "Fail"
+  | Ni -> "Ni"
+  | Nomem -> "Nomem"
+  | Inval -> "Inval"
+  | Badfail -> "Badfail"
+  | Guest_Timedout -> "Guest Timedout"
+  | Timedout -> "Timedout"
+  | Noparavirt -> "Noparavirt"
+  | Not_Ready -> "Not Ready"
+  | Osevent_Reg_Fail -> "Osevent Reg Fail"
+  | Bufferfull -> "Bufferfull"
+  | Unknown_Child -> "Unknown Child"
+
+exception Error of (error * string)
+
+type ctx
+
+external ctx_alloc: Xentoollog.handle -> ctx = "stub_libxl_ctx_alloc"
+external ctx_free: ctx -> unit = "stub_libxl_ctx_free"
+
+external test_raise_exception: unit -> unit = "stub_raise_exception"
 
 type domid = int
 type devid = int
@@ -26,15 +66,10 @@ end
 
 (* @@LIBXL_TYPES@@ *)
 
-type ctx
-
-external ctx_alloc: Xentoollog.handle -> ctx = "stub_libxl_ctx_alloc"
-external ctx_free: ctx -> unit = "stub_libxl_ctx_free"
-
 external list_domain: ctx -> Dominfo.t list = "stub_libxl_list_domain"
 
 external send_trigger : domid -> trigger -> int -> unit = "stub_xl_send_trigger"
 external send_sysrq : domid -> char -> unit = "stub_xl_send_sysrq"
 external send_debug_keys : ctx -> string -> unit = "stub_xl_send_debug_keys"
 
-let _ = Callback.register_exception "Xenlight.Error" (Error(""))
+let _ = Callback.register_exception "Xenlight.Error" (Error(Fail, ""))
diff -r e4525795eac2 -r c8d22bfef298 tools/ocaml/libs/xl/xenlight.mli.in
--- a/tools/ocaml/libs/xl/xenlight.mli.in	Tue Nov 20 17:22:21 2012 +0000
+++ b/tools/ocaml/libs/xl/xenlight.mli.in	Tue Nov 20 17:22:21 2012 +0000
@@ -15,7 +15,32 @@
 
 open Xentoollog
 
-exception Error of string
+type error = 
+    Nonspecific |
+    Version |
+    Fail |
+    Ni |
+    Nomem |
+    Inval |
+    Badfail |
+    Guest_Timedout |
+    Timedout |
+    Noparavirt |
+    Not_Ready |
+    Osevent_Reg_Fail |
+    Bufferfull |
+    Unknown_Child
+
+val string_of_error: error -> string
+
+exception Error of (error * string)
+
+type ctx
+
+external ctx_alloc: Xentoollog.handle -> ctx = "stub_libxl_ctx_alloc"
+external ctx_free: ctx -> unit = "stub_libxl_ctx_free"
+
+external test_raise_exception: unit = "stub_raise_exception"
 
 type domid = int
 type devid = int
@@ -24,9 +49,6 @@ type devid = int
 
 type ctx
 
-external ctx_alloc: Xentoollog.handle -> ctx = "stub_libxl_ctx_alloc"
-external ctx_free: ctx -> unit = "stub_libxl_ctx_free"
-
 external list_domain: ctx -> Dominfo.t list = "stub_libxl_list_domain"
 
 external send_trigger : domid -> trigger -> int -> unit = "stub_xl_send_trigger"
diff -r e4525795eac2 -r c8d22bfef298 tools/ocaml/libs/xl/xenlight_stubs.c
--- a/tools/ocaml/libs/xl/xenlight_stubs.c	Tue Nov 20 17:22:21 2012 +0000
+++ b/tools/ocaml/libs/xl/xenlight_stubs.c	Tue Nov 20 17:22:21 2012 +0000
@@ -43,12 +43,54 @@ static char * dup_String_val(value s)
 	return c;
 }
 
-static void failwith_xl(char *fname)
+static value Val_error(int error)
 {
+	switch (error) {
+	case ERROR_NONSPECIFIC: return Val_int(0);
+	case ERROR_VERSION:     return Val_int(1);
+	case ERROR_FAIL:        return Val_int(2);
+	case ERROR_NI:          return Val_int(3);
+	case ERROR_NOMEM:       return Val_int(4);
+	case ERROR_INVAL:       return Val_int(5);
+	case ERROR_BADFAIL:     return Val_int(6);
+	case ERROR_GUEST_TIMEDOUT: return Val_int(7);
+	case ERROR_TIMEDOUT:    return Val_int(8);
+	case ERROR_NOPARAVIRT:  return Val_int(9);
+	case ERROR_NOT_READY:   return Val_int(10);
+	case ERROR_OSEVENT_REG_FAIL: return Val_int(11);
+	case ERROR_BUFFERFULL:  return Val_int(12);
+	case ERROR_UNKNOWN_CHILD: return Val_int(13);
+#if 0 /* Let the compiler catch this */
+	default:
+		caml_raise_sys_error(caml_copy_string("Unknown libxl ERROR"));
+		break;
+#endif
+	}
+	/* Should not reach here */
+	abort();
+}
+
+static void failwith_xl(int error, char *fname)
+{
+	CAMLlocal1(arg);
 	value *exc = caml_named_value("Xenlight.Error");
+
 	if (!exc)
 		caml_invalid_argument("Exception Xenlight.Error not initialized, please link xl.cma");
-	caml_raise_with_string(*exc, fname);
+
+	arg = caml_alloc_small(2, 0);
+
+	Field(arg, 0) = Val_error(error);
+	Field(arg, 1) = caml_copy_string(fname);
+
+	caml_raise_with_arg(*exc, arg);
+}
+
+CAMLprim value stub_raise_exception(value unit)
+{
+	CAMLparam1(unit);
+	failwith_xl(ERROR_FAIL, "test exception");
+	CAMLreturn(Val_unit);
 }
 
 CAMLprim value stub_libxl_ctx_alloc(value logger)
@@ -60,7 +102,7 @@ CAMLprim value stub_libxl_ctx_alloc(valu
 	caml_enter_blocking_section();
 	ret = libxl_ctx_alloc(&ctx, LIBXL_VERSION, 0, (struct xentoollog_logger *) logger);
 	if (ret != 0) \
-		failwith_xl("cannot init context");
+		failwith_xl(ERROR_FAIL, "cannot init context");
 	caml_leave_blocking_section();
 	CAMLreturn((value)ctx);
 }
@@ -190,7 +232,7 @@ static int Bitmap_val(libxl_ctx *ctx, li
 	int i, len = Wosize_val(v);
 
 	if (!libxl_bitmap_alloc(ctx, c_val, len))
-		failwith_xl("cannot allocate bitmap");
+		failwith_xl(ERROR_NOMEM, "cannot allocate bitmap");
 	for (i=0; i<len; i++) {
 		if (Int_val(Field(v, i)))
 			libxl_bitmap_set(c_val, i);
@@ -295,7 +337,7 @@ value stub_libxl_list_domain(value ctx)
 
 	info = libxl_list_domain(CTX, &nr);
 	if (info == NULL)
-		failwith_xl("list_domain");
+		failwith_xl(ERROR_FAIL, "list_domain");
 
 	cli = Val_emptylist;
 
@@ -332,7 +374,7 @@ value stub_xl_device_##type##_##op(value
 	libxl_device_##type##_dispose(&c_info);				\
 									\
 	if (ret != 0)							\
-		failwith_xl(STRINGIFY(type) "_" STRINGIFY(op));		\
+		failwith_xl(ret, STRINGIFY(type) "_" STRINGIFY(op));	\
 									\
 	CAMLreturn(Val_unit);						\
 }
@@ -358,7 +400,7 @@ value stub_xl_physinfo_get(value ctx)
 	ret = libxl_get_physinfo(CTX, &c_physinfo);
 
 	if (ret != 0)
-		failwith_xl("get_physinfo");
+		failwith_xl(ret, "get_physinfo");
 
 	physinfo = Val_physinfo(CTX, &c_physinfo);
 
@@ -377,7 +419,7 @@ value stub_xl_cputopology_get(value ctx)
 	c_topology = libxl_get_cpu_topology(CTX, &nr);
 
 	if (!c_topology)
-		failwith_xl("topologyinfo");
+		failwith_xl(ERROR_FAIL, "get_cpu_topologyinfo");
 
 	topology = caml_alloc_tuple(nr);
 	for (i = 0; i < nr; i++) {
@@ -402,7 +444,7 @@ value stub_xl_domain_sched_params_get(va
 
 	ret = libxl_domain_sched_params_get(CTX, Int_val(domid), &c_scinfo);
 	if (ret != 0)
-		failwith_xl("domain_sched_params_get");
+		failwith_xl(ret, "domain_sched_params_get");
 
 	scinfo = Val_domain_sched_params(CTX, &c_scinfo);
 
@@ -424,7 +466,7 @@ value stub_xl_domain_sched_params_set(va
 	libxl_domain_sched_params_dispose(&c_scinfo);
 
 	if (ret != 0)
-		failwith_xl("domain_sched_params_set");
+		failwith_xl(ret, "domain_sched_params_set");
 
 	CAMLreturn(Val_unit);
 }
@@ -441,7 +483,7 @@ value stub_xl_send_trigger(value ctx, va
 				 c_trigger, Int_val(vcpuid));
 
 	if (ret != 0)
-		failwith_xl("send_trigger");
+		failwith_xl(ret, "send_trigger");
 
 	CAMLreturn(Val_unit);
 }
@@ -454,7 +496,7 @@ value stub_xl_send_sysrq(value ctx, valu
 	ret = libxl_send_sysrq(CTX, Int_val(domid), Int_val(sysrq));
 
 	if (ret != 0)
-		failwith_xl("send_sysrq");
+		failwith_xl(ret, "send_sysrq");
 
 	CAMLreturn(Val_unit);
 }
@@ -469,7 +511,7 @@ value stub_xl_send_debug_keys(value ctx,
 
 	ret = libxl_send_debug_keys(CTX, c_keys);
 	if (ret != 0)
-		failwith_xl("send_debug_keys");
+		failwith_xl(ret, "send_debug_keys");
 
 	free(c_keys);
 
diff -r e4525795eac2 -r c8d22bfef298 tools/ocaml/test/Makefile
--- a/tools/ocaml/test/Makefile	Tue Nov 20 17:22:21 2012 +0000
+++ b/tools/ocaml/test/Makefile	Tue Nov 20 17:22:21 2012 +0000
@@ -6,9 +6,9 @@ OCAMLINCLUDE += \
 	-I $(OCAML_TOPLEVEL)/libs/xentoollog \
 	-I $(OCAML_TOPLEVEL)/libs/xl
 
-OBJS = xtl send_debug_keys list_domains
+OBJS = xtl send_debug_keys list_domains raise_exception
 
-PROGRAMS = xtl send_debug_keys list_domains
+PROGRAMS = xtl send_debug_keys list_domains raise_exception
 
 xtl_LIBS =  \
 	-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xentoollog $(OCAML_TOPLEVEL)/libs/xentoollog/xentoollog.cmxa
@@ -27,7 +27,13 @@ list_domains_LIBS =  \
 
 list_domains_OBJS = list_domains
 
-OCAML_PROGRAM = xtl send_debug_keys list_domains
+raise_exception_LIBS =  \
+	-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xentoollog $(OCAML_TOPLEVEL)/libs/xentoollog/xentoollog.cmxa \
+	-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xl $(OCAML_TOPLEVEL)/libs/xl/xenlight.cmxa
+
+raise_exception_OBJS = raise_exception
+
+OCAML_PROGRAM = xtl send_debug_keys list_domains raise_exception
 
 all: $(PROGRAMS)
 
diff -r e4525795eac2 -r c8d22bfef298 tools/ocaml/test/list_domains.ml
--- a/tools/ocaml/test/list_domains.ml	Tue Nov 20 17:22:21 2012 +0000
+++ b/tools/ocaml/test/list_domains.ml	Tue Nov 20 17:22:21 2012 +0000
@@ -19,8 +19,11 @@ let print_dominfo dominfo =
 let _ = 
   let logger = Xentoollog.create_stdio_logger (*~level:Xentoollog.Debug*) () in
   let ctx = Xenlight.ctx_alloc logger in
-  let domains = Xenlight.list_domain ctx in
-  List.iter (fun d -> print_dominfo d) domains;
-  Xenlight.ctx_free ctx;
-  Xentoollog.destroy logger;
-
+  try
+    let domains = Xenlight.list_domain ctx in
+    List.iter (fun d -> print_dominfo d) domains;
+    Xenlight.ctx_free ctx;
+    Xentoollog.destroy logger;
+  with Xenlight.Error(err, fn) -> begin
+    printf "Caught Exception: %s: %s\n" (Xenlight.string_of_error err) fn;
+  end
diff -r e4525795eac2 -r c8d22bfef298 tools/ocaml/test/raise_exception.ml
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/test/raise_exception.ml	Tue Nov 20 17:22:21 2012 +0000
@@ -0,0 +1,15 @@
+open Printf
+open Xentoollog
+open Xenlight
+
+let _ = 
+  let logger = Xentoollog.create_stdio_logger (*~level:Xentoollog.Debug*) () in
+  let ctx = Xenlight.ctx_alloc logger in
+  try
+    Xenlight.test_raise_exception ()
+  with Xenlight.Error(err, fn) -> begin
+    printf "Caught Exception: %s: %s\n" (Xenlight.string_of_error err) fn;
+  end;
+  Xenlight.ctx_free ctx;
+  Xentoollog.destroy logger;
+