+(* Generate ruby bindings. *)
+and generate_ruby_c () =
+ generate_header CStyle LGPLv2;
+
+ pr "\
+#include <stdio.h>
+#include <stdlib.h>
+
+#include <ruby.h>
+
+#include \"guestfs.h\"
+
+#include \"extconf.h\"
+
+/* For Ruby < 1.9 */
+#ifndef RARRAY_LEN
+#define RARRAY_LEN(r) (RARRAY((r))->len)
+#endif
+
+static VALUE m_guestfs; /* guestfs module */
+static VALUE c_guestfs; /* guestfs_h handle */
+static VALUE e_Error; /* used for all errors */
+
+static void ruby_guestfs_free (void *p)
+{
+ if (!p) return;
+ guestfs_close ((guestfs_h *) p);
+}
+
+static VALUE ruby_guestfs_create (VALUE m)
+{
+ guestfs_h *g;
+
+ g = guestfs_create ();
+ if (!g)
+ rb_raise (e_Error, \"failed to create guestfs handle\");
+
+ /* Don't print error messages to stderr by default. */
+ guestfs_set_error_handler (g, NULL, NULL);
+
+ /* Wrap it, and make sure the close function is called when the
+ * handle goes away.
+ */
+ return Data_Wrap_Struct (c_guestfs, NULL, ruby_guestfs_free, g);
+}
+
+static VALUE ruby_guestfs_close (VALUE gv)
+{
+ guestfs_h *g;
+ Data_Get_Struct (gv, guestfs_h, g);
+
+ ruby_guestfs_free (g);
+ DATA_PTR (gv) = NULL;
+
+ return Qnil;
+}
+
+";
+
+ List.iter (
+ fun (name, style, _, _, _, _, _) ->
+ pr "static VALUE ruby_guestfs_%s (VALUE gv" name;
+ List.iter (fun arg -> pr ", VALUE %sv" (name_of_argt arg)) (snd style);
+ pr ")\n";
+ pr "{\n";
+ pr " guestfs_h *g;\n";
+ pr " Data_Get_Struct (gv, guestfs_h, g);\n";
+ pr " if (!g)\n";
+ pr " rb_raise (rb_eArgError, \"%%s: used handle after closing it\", \"%s\");\n"
+ name;
+ pr "\n";
+
+ List.iter (
+ function
+ | String n | FileIn n | FileOut n ->
+ pr " const char *%s = StringValueCStr (%sv);\n" n n;
+ pr " if (!%s)\n" n;
+ pr " rb_raise (rb_eTypeError, \"expected string for parameter %%s of %%s\",\n";
+ pr " \"%s\", \"%s\");\n" n name
+ | OptString n ->
+ pr " const char *%s = StringValueCStr (%sv);\n" n n
+ | StringList n ->
+ pr " char **%s;" n;
+ pr " {\n";
+ pr " int i, len;\n";
+ pr " len = RARRAY_LEN (%sv);\n" n;
+ pr " %s = guestfs_safe_malloc (g, sizeof (char *) * (len+1));\n"
+ n;
+ pr " for (i = 0; i < len; ++i) {\n";
+ pr " VALUE v = rb_ary_entry (%sv, i);\n" n;
+ pr " %s[i] = StringValueCStr (v);\n" n;
+ pr " }\n";
+ pr " %s[len] = NULL;\n" n;
+ pr " }\n";
+ | Bool n
+ | Int n ->
+ pr " int %s = NUM2INT (%sv);\n" n n
+ ) (snd style);
+ pr "\n";
+
+ let error_code =
+ match fst style with
+ | RErr | RInt _ | RBool _ -> pr " int r;\n"; "-1"
+ | RInt64 _ -> pr " int64_t r;\n"; "-1"
+ | RConstString _ -> pr " const char *r;\n"; "NULL"
+ | RString _ -> pr " char *r;\n"; "NULL"
+ | RStringList _ | RHashtable _ -> pr " char **r;\n"; "NULL"
+ | RIntBool _ -> pr " struct guestfs_int_bool *r;\n"; "NULL"
+ | RPVList n -> pr " struct guestfs_lvm_pv_list *r;\n"; "NULL"
+ | RVGList n -> pr " struct guestfs_lvm_vg_list *r;\n"; "NULL"
+ | RLVList n -> pr " struct guestfs_lvm_lv_list *r;\n"; "NULL"
+ | RStat n -> pr " struct guestfs_stat *r;\n"; "NULL"
+ | RStatVFS n -> pr " struct guestfs_statvfs *r;\n"; "NULL" in
+ pr "\n";
+
+ pr " r = guestfs_%s " name;
+ generate_call_args ~handle:"g" (snd style);
+ pr ";\n";
+
+ List.iter (
+ function
+ | String _ | FileIn _ | FileOut _ | OptString _ | Bool _ | Int _ -> ()
+ | StringList n ->
+ pr " free (%s);\n" n
+ ) (snd style);
+
+ pr " if (r == %s)\n" error_code;
+ pr " rb_raise (e_Error, \"%%s\", guestfs_last_error (g));\n";
+ pr "\n";
+
+ (match fst style with
+ | RErr ->
+ pr " return Qnil;\n"
+ | RInt _ | RBool _ ->
+ pr " return INT2NUM (r);\n"
+ | RInt64 _ ->
+ pr " return ULL2NUM (r);\n"
+ | RConstString _ ->
+ pr " return rb_str_new2 (r);\n";
+ | RString _ ->
+ pr " VALUE rv = rb_str_new2 (r);\n";
+ pr " free (r);\n";
+ pr " return rv;\n";
+ | RStringList _ ->
+ pr " int i, len = 0;\n";
+ pr " for (i = 0; r[i] != NULL; ++i) len++;\n";
+ pr " VALUE rv = rb_ary_new2 (len);\n";
+ pr " for (i = 0; r[i] != NULL; ++i) {\n";
+ pr " rb_ary_push (rv, rb_str_new2 (r[i]));\n";
+ pr " free (r[i]);\n";
+ pr " }\n";
+ pr " free (r);\n";
+ pr " return rv;\n"
+ | RIntBool _ ->
+ pr " VALUE rv = rb_ary_new2 (2);\n";
+ pr " rb_ary_push (rv, INT2NUM (r->i));\n";
+ pr " rb_ary_push (rv, INT2NUM (r->b));\n";
+ pr " guestfs_free_int_bool (r);\n";
+ pr " return rv;\n"
+ | RPVList n ->
+ generate_ruby_lvm_code "pv" pv_cols
+ | RVGList n ->
+ generate_ruby_lvm_code "vg" vg_cols
+ | RLVList n ->
+ generate_ruby_lvm_code "lv" lv_cols
+ | RStat n ->
+ pr " VALUE rv = rb_hash_new ();\n";
+ List.iter (
+ function
+ | name, `Int ->
+ pr " rb_hash_aset (rv, rb_str_new2 (\"%s\"), ULL2NUM (r->%s));\n" name name
+ ) stat_cols;
+ pr " free (r);\n";
+ pr " return rv;\n"
+ | RStatVFS n ->
+ pr " VALUE rv = rb_hash_new ();\n";
+ List.iter (
+ function
+ | name, `Int ->
+ pr " rb_hash_aset (rv, rb_str_new2 (\"%s\"), ULL2NUM (r->%s));\n" name name
+ ) statvfs_cols;
+ pr " free (r);\n";
+ pr " return rv;\n"
+ | RHashtable _ ->
+ pr " VALUE rv = rb_hash_new ();\n";
+ pr " int i;\n";
+ pr " for (i = 0; r[i] != NULL; i+=2) {\n";
+ pr " rb_hash_aset (rv, rb_str_new2 (r[i]), rb_str_new2 (r[i+1]));\n";
+ pr " free (r[i]);\n";
+ pr " free (r[i+1]);\n";
+ pr " }\n";
+ pr " free (r);\n";
+ pr " return rv;\n"
+ );
+
+ pr "}\n";
+ pr "\n"
+ ) all_functions;
+
+ pr "\
+/* Initialize the module. */
+void Init__guestfs ()
+{
+ m_guestfs = rb_define_module (\"Guestfs\");
+ c_guestfs = rb_define_class_under (m_guestfs, \"Guestfs\", rb_cObject);
+ e_Error = rb_define_class_under (m_guestfs, \"Error\", rb_eStandardError);
+
+ rb_define_module_function (m_guestfs, \"create\", ruby_guestfs_create, 0);
+ rb_define_method (c_guestfs, \"close\", ruby_guestfs_close, 0);
+
+";
+ (* Define the rest of the methods. *)
+ List.iter (
+ fun (name, style, _, _, _, _, _) ->
+ pr " rb_define_method (c_guestfs, \"%s\",\n" name;
+ pr " ruby_guestfs_%s, %d);\n" name (List.length (snd style))
+ ) all_functions;
+
+ pr "}\n"
+
+(* Ruby code to return an LVM struct list. *)
+and generate_ruby_lvm_code typ cols =
+ pr " VALUE rv = rb_ary_new2 (r->len);\n";
+ pr " int i;\n";
+ pr " for (i = 0; i < r->len; ++i) {\n";
+ pr " VALUE hv = rb_hash_new ();\n";
+ List.iter (
+ function
+ | name, `String ->
+ pr " rb_hash_aset (rv, rb_str_new2 (\"%s\"), rb_str_new2 (r->val[i].%s));\n" name name
+ | name, `UUID ->
+ pr " rb_hash_aset (rv, rb_str_new2 (\"%s\"), rb_str_new (r->val[i].%s, 32));\n" name name
+ | name, `Bytes
+ | name, `Int ->
+ pr " rb_hash_aset (rv, rb_str_new2 (\"%s\"), ULL2NUM (r->val[i].%s));\n" name name
+ | name, `OptPercent ->
+ pr " rb_hash_aset (rv, rb_str_new2 (\"%s\"), rb_dbl2big (r->val[i].%s));\n" name name
+ ) cols;
+ pr " rb_ary_push (rv, hv);\n";
+ pr " }\n";
+ pr " guestfs_free_lvm_%s_list (r);\n" typ;
+ pr " return rv;\n"
+
+(* Generate Java bindings GuestFS.java file. *)
+and generate_java_java () =
+ generate_header CStyle LGPLv2;
+
+ pr "\
+package com.redhat.et.libguestfs;
+
+import java.util.HashMap;
+import com.redhat.et.libguestfs.LibGuestFSException;
+import com.redhat.et.libguestfs.PV;
+import com.redhat.et.libguestfs.VG;
+import com.redhat.et.libguestfs.LV;
+import com.redhat.et.libguestfs.Stat;
+import com.redhat.et.libguestfs.StatVFS;
+import com.redhat.et.libguestfs.IntBool;
+
+/**
+ * The GuestFS object is a libguestfs handle.
+ *
+ * @author rjones
+ */
+public class GuestFS {
+ // Load the native code.
+ static {
+ System.loadLibrary (\"guestfs_jni\");
+ }
+
+ /**
+ * The native guestfs_h pointer.
+ */
+ long g;
+
+ /**
+ * Create a libguestfs handle.
+ *
+ * @throws LibGuestFSException
+ */
+ public GuestFS () throws LibGuestFSException
+ {
+ g = _create ();
+ }
+ private native long _create () throws LibGuestFSException;
+
+ /**
+ * Close a libguestfs handle.
+ *
+ * You can also leave handles to be collected by the garbage
+ * collector, but this method ensures that the resources used
+ * by the handle are freed up immediately. If you call any
+ * other methods after closing the handle, you will get an
+ * exception.
+ *
+ * @throws LibGuestFSException
+ */
+ public void close () throws LibGuestFSException
+ {
+ if (g != 0)
+ _close (g);
+ g = 0;
+ }
+ private native void _close (long g) throws LibGuestFSException;
+
+ public void finalize () throws LibGuestFSException
+ {
+ close ();
+ }
+
+";
+
+ List.iter (
+ fun (name, style, _, flags, _, shortdesc, longdesc) ->
+ let doc = replace_str longdesc "C<guestfs_" "C<g." in
+ let doc =
+ if List.mem ProtocolLimitWarning flags then
+ doc ^ "\n\n" ^ protocol_limit_warning
+ else doc in
+ let doc =
+ if List.mem DangerWillRobinson flags then
+ doc ^ "\n\n" ^ danger_will_robinson
+ else doc in
+ let doc = pod2text ~width:60 name doc in
+ let doc = String.concat "\n * " doc in
+
+ pr " /**\n";
+ pr " * %s\n" shortdesc;
+ pr " *\n";
+ pr " * %s\n" doc;
+ pr " * @throws LibGuestFSException\n";
+ pr " */\n";
+ pr " ";
+ generate_java_prototype ~public:true ~semicolon:false name style;
+ pr "\n";
+ pr " {\n";
+ pr " if (g == 0)\n";
+ pr " throw new LibGuestFSException (\"%s: handle is closed\");\n"
+ name;
+ pr " ";
+ if fst style <> RErr then pr "return ";
+ pr "_%s " name;
+ generate_call_args ~handle:"g" (snd style);
+ pr ";\n";
+ pr " }\n";
+ pr " ";
+ generate_java_prototype ~privat:true ~native:true name style;
+ pr "\n";
+ pr "\n";
+ ) all_functions;
+
+ pr "}\n"
+
+and generate_java_prototype ?(public=false) ?(privat=false) ?(native=false)
+ ?(semicolon=true) name style =
+ if privat then pr "private ";
+ if public then pr "public ";
+ if native then pr "native ";
+
+ (* return type *)
+ (match fst style with
+ | RErr -> pr "void ";
+ | RInt _ -> pr "int ";
+ | RInt64 _ -> pr "long ";
+ | RBool _ -> pr "boolean ";
+ | RConstString _ | RString _ -> pr "String ";
+ | RStringList _ -> pr "String[] ";
+ | RIntBool _ -> pr "IntBool ";
+ | RPVList _ -> pr "PV[] ";
+ | RVGList _ -> pr "VG[] ";
+ | RLVList _ -> pr "LV[] ";
+ | RStat _ -> pr "Stat ";
+ | RStatVFS _ -> pr "StatVFS ";
+ | RHashtable _ -> pr "HashMap<String,String> ";
+ );
+
+ if native then pr "_%s " name else pr "%s " name;
+ pr "(";
+ let needs_comma = ref false in
+ if native then (
+ pr "long g";
+ needs_comma := true
+ );
+
+ (* args *)
+ List.iter (
+ fun arg ->
+ if !needs_comma then pr ", ";
+ needs_comma := true;
+
+ match arg with
+ | String n
+ | OptString n
+ | FileIn n
+ | FileOut n ->
+ pr "String %s" n
+ | StringList n ->
+ pr "String[] %s" n
+ | Bool n ->
+ pr "boolean %s" n
+ | Int n ->
+ pr "int %s" n
+ ) (snd style);
+
+ pr ")\n";
+ pr " throws LibGuestFSException";
+ if semicolon then pr ";"
+
+and generate_java_struct typ cols =
+ generate_header CStyle LGPLv2;
+
+ pr "\
+package com.redhat.et.libguestfs;
+
+/**
+ * Libguestfs %s structure.
+ *
+ * @author rjones
+ * @see GuestFS
+ */
+public class %s {
+" typ typ;
+
+ List.iter (
+ function
+ | name, `String
+ | name, `UUID -> pr " public String %s;\n" name
+ | name, `Bytes
+ | name, `Int -> pr " public long %s;\n" name
+ | name, `OptPercent ->
+ pr " /* The next field is [0..100] or -1 meaning 'not present': */\n";
+ pr " public float %s;\n" name
+ ) cols;
+
+ pr "}\n"
+
+and generate_java_c () =
+ generate_header CStyle LGPLv2;
+
+ pr "\
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+#include \"com_redhat_et_libguestfs_GuestFS.h\"
+#include \"guestfs.h\"
+
+/* Note that this function returns. The exception is not thrown
+ * until after the wrapper function returns.
+ */
+static void
+throw_exception (JNIEnv *env, const char *msg)
+{
+ jclass cl;
+ cl = (*env)->FindClass (env,
+ \"com/redhat/et/libguestfs/LibGuestFSException\");
+ (*env)->ThrowNew (env, cl, msg);
+}
+
+JNIEXPORT jlong JNICALL
+Java_com_redhat_et_libguestfs_GuestFS__1create
+ (JNIEnv *env, jobject obj)
+{
+ guestfs_h *g;
+
+ g = guestfs_create ();
+ if (g == NULL) {
+ throw_exception (env, \"GuestFS.create: failed to allocate handle\");
+ return 0;
+ }
+ guestfs_set_error_handler (g, NULL, NULL);
+ return (jlong) (long) g;
+}
+
+JNIEXPORT void JNICALL
+Java_com_redhat_et_libguestfs_GuestFS__1close
+ (JNIEnv *env, jobject obj, jlong jg)
+{
+ guestfs_h *g = (guestfs_h *) (long) jg;
+ guestfs_close (g);
+}
+
+";
+
+ List.iter (
+ fun (name, style, _, _, _, _, _) ->
+ pr "JNIEXPORT ";
+ (match fst style with
+ | RErr -> pr "void ";
+ | RInt _ -> pr "jint ";
+ | RInt64 _ -> pr "jlong ";
+ | RBool _ -> pr "jboolean ";
+ | RConstString _ | RString _ -> pr "jstring ";
+ | RIntBool _ | RStat _ | RStatVFS _ | RHashtable _ ->
+ pr "jobject ";
+ | RStringList _ | RPVList _ | RVGList _ | RLVList _ ->
+ pr "jobjectArray ";
+ );
+ pr "JNICALL\n";
+ pr "Java_com_redhat_et_libguestfs_GuestFS_";
+ pr "%s" (replace_str ("_" ^ name) "_" "_1");
+ pr "\n";
+ pr " (JNIEnv *env, jobject obj, jlong jg";
+ List.iter (
+ function
+ | String n
+ | OptString n
+ | FileIn n
+ | FileOut n ->
+ pr ", jstring j%s" n
+ | StringList n ->
+ pr ", jobjectArray j%s" n
+ | Bool n ->
+ pr ", jboolean j%s" n
+ | Int n ->
+ pr ", jint j%s" n
+ ) (snd style);
+ pr ")\n";
+ pr "{\n";
+ pr " guestfs_h *g = (guestfs_h *) (long) jg;\n";
+ let error_code, no_ret =
+ match fst style with
+ | RErr -> pr " int r;\n"; "-1", ""
+ | RBool _
+ | RInt _ -> pr " int r;\n"; "-1", "0"
+ | RInt64 _ -> pr " int64_t r;\n"; "-1", "0"
+ | RConstString _ -> pr " const char *r;\n"; "NULL", "NULL"
+ | RString _ ->
+ pr " jstring jr;\n";
+ pr " char *r;\n"; "NULL", "NULL"
+ | RStringList _ ->
+ pr " jobjectArray jr;\n";
+ pr " int r_len;\n";
+ pr " jclass cl;\n";
+ pr " jstring jstr;\n";
+ pr " char **r;\n"; "NULL", "NULL"
+ | RIntBool _ ->
+ pr " jobject jr;\n";
+ pr " jclass cl;\n";
+ pr " jfieldID fl;\n";
+ pr " struct guestfs_int_bool *r;\n"; "NULL", "NULL"
+ | RStat _ ->
+ pr " jobject jr;\n";
+ pr " jclass cl;\n";
+ pr " jfieldID fl;\n";
+ pr " struct guestfs_stat *r;\n"; "NULL", "NULL"
+ | RStatVFS _ ->
+ pr " jobject jr;\n";
+ pr " jclass cl;\n";
+ pr " jfieldID fl;\n";
+ pr " struct guestfs_statvfs *r;\n"; "NULL", "NULL"
+ | RPVList _ ->
+ pr " jobjectArray jr;\n";
+ pr " jclass cl;\n";
+ pr " jfieldID fl;\n";
+ pr " jobject jfl;\n";
+ pr " struct guestfs_lvm_pv_list *r;\n"; "NULL", "NULL"
+ | RVGList _ ->
+ pr " jobjectArray jr;\n";
+ pr " jclass cl;\n";
+ pr " jfieldID fl;\n";
+ pr " jobject jfl;\n";
+ pr " struct guestfs_lvm_vg_list *r;\n"; "NULL", "NULL"
+ | RLVList _ ->
+ pr " jobjectArray jr;\n";
+ pr " jclass cl;\n";
+ pr " jfieldID fl;\n";
+ pr " jobject jfl;\n";
+ pr " struct guestfs_lvm_lv_list *r;\n"; "NULL", "NULL"
+ | RHashtable _ -> pr " char **r;\n"; "NULL", "NULL" in
+ List.iter (
+ function
+ | String n
+ | OptString n
+ | FileIn n
+ | FileOut n ->
+ pr " const char *%s;\n" n
+ | StringList n ->
+ pr " int %s_len;\n" n;
+ pr " const char **%s;\n" n
+ | Bool n
+ | Int n ->
+ pr " int %s;\n" n
+ ) (snd style);
+
+ let needs_i =
+ (match fst style with
+ | RStringList _ | RPVList _ | RVGList _ | RLVList _ -> true
+ | RErr | RBool _ | RInt _ | RInt64 _ | RConstString _
+ | RString _ | RIntBool _ | RStat _ | RStatVFS _
+ | RHashtable _ -> false) ||
+ List.exists (function StringList _ -> true | _ -> false) (snd style) in
+ if needs_i then
+ pr " int i;\n";
+
+ pr "\n";
+
+ (* Get the parameters. *)
+ List.iter (
+ function
+ | String n
+ | OptString n
+ | FileIn n
+ | FileOut n ->
+ pr " %s = (*env)->GetStringUTFChars (env, j%s, NULL);\n" n n
+ | StringList n ->
+ pr " %s_len = (*env)->GetArrayLength (env, j%s);\n" n n;
+ pr " %s = guestfs_safe_malloc (g, sizeof (char *) * (%s_len+1));\n" n n;
+ pr " for (i = 0; i < %s_len; ++i) {\n" n;
+ pr " jobject o = (*env)->GetObjectArrayElement (env, j%s, i);\n"
+ n;
+ pr " %s[i] = (*env)->GetStringUTFChars (env, o, NULL);\n" n;
+ pr " }\n";
+ pr " %s[%s_len] = NULL;\n" n n;
+ | Bool n
+ | Int n ->
+ pr " %s = j%s;\n" n n
+ ) (snd style);
+
+ (* Make the call. *)
+ pr " r = guestfs_%s " name;
+ generate_call_args ~handle:"g" (snd style);
+ pr ";\n";
+
+ (* Release the parameters. *)
+ List.iter (
+ function
+ | String n
+ | OptString n
+ | FileIn n
+ | FileOut n ->
+ pr " (*env)->ReleaseStringUTFChars (env, j%s, %s);\n" n n
+ | StringList n ->
+ pr " for (i = 0; i < %s_len; ++i) {\n" n;
+ pr " jobject o = (*env)->GetObjectArrayElement (env, j%s, i);\n"
+ n;
+ pr " (*env)->ReleaseStringUTFChars (env, o, %s[i]);\n" n;
+ pr " }\n";
+ pr " free (%s);\n" n
+ | Bool n
+ | Int n -> ()
+ ) (snd style);
+
+ (* Check for errors. *)
+ pr " if (r == %s) {\n" error_code;
+ pr " throw_exception (env, guestfs_last_error (g));\n";
+ pr " return %s;\n" no_ret;
+ pr " }\n";
+
+ (* Return value. *)
+ (match fst style with
+ | RErr -> ()
+ | RInt _ -> pr " return (jint) r;\n"
+ | RBool _ -> pr " return (jboolean) r;\n"
+ | RInt64 _ -> pr " return (jlong) r;\n"
+ | RConstString _ -> pr " return (*env)->NewStringUTF (env, r);\n"
+ | RString _ ->
+ pr " jr = (*env)->NewStringUTF (env, r);\n";
+ pr " free (r);\n";
+ pr " return jr;\n"
+ | RStringList _ ->
+ pr " for (r_len = 0; r[r_len] != NULL; ++r_len) ;\n";
+ pr " cl = (*env)->FindClass (env, \"java/lang/String\");\n";
+ pr " jstr = (*env)->NewStringUTF (env, \"\");\n";
+ pr " jr = (*env)->NewObjectArray (env, r_len, cl, jstr);\n";
+ pr " for (i = 0; i < r_len; ++i) {\n";
+ pr " jstr = (*env)->NewStringUTF (env, r[i]);\n";
+ pr " (*env)->SetObjectArrayElement (env, jr, i, jstr);\n";
+ pr " free (r[i]);\n";
+ pr " }\n";
+ pr " free (r);\n";
+ pr " return jr;\n"
+ | RIntBool _ ->
+ pr " cl = (*env)->FindClass (env, \"com/redhat/et/libguestfs/IntBool\");\n";
+ pr " jr = (*env)->AllocObject (env, cl);\n";
+ pr " fl = (*env)->GetFieldID (env, cl, \"i\", \"I\");\n";
+ pr " (*env)->SetIntField (env, jr, fl, r->i);\n";
+ pr " fl = (*env)->GetFieldID (env, cl, \"i\", \"Z\");\n";
+ pr " (*env)->SetBooleanField (env, jr, fl, r->b);\n";
+ pr " guestfs_free_int_bool (r);\n";
+ pr " return jr;\n"
+ | RStat _ ->
+ pr " cl = (*env)->FindClass (env, \"com/redhat/et/libguestfs/Stat\");\n";
+ pr " jr = (*env)->AllocObject (env, cl);\n";
+ List.iter (
+ function
+ | name, `Int ->
+ pr " fl = (*env)->GetFieldID (env, cl, \"%s\", \"J\");\n"
+ name;
+ pr " (*env)->SetLongField (env, jr, fl, r->%s);\n" name;
+ ) stat_cols;
+ pr " free (r);\n";
+ pr " return jr;\n"
+ | RStatVFS _ ->
+ pr " cl = (*env)->FindClass (env, \"com/redhat/et/libguestfs/StatVFS\");\n";
+ pr " jr = (*env)->AllocObject (env, cl);\n";
+ List.iter (
+ function
+ | name, `Int ->
+ pr " fl = (*env)->GetFieldID (env, cl, \"%s\", \"J\");\n"
+ name;
+ pr " (*env)->SetLongField (env, jr, fl, r->%s);\n" name;
+ ) statvfs_cols;
+ pr " free (r);\n";
+ pr " return jr;\n"
+ | RPVList _ ->
+ generate_java_lvm_return "pv" "PV" pv_cols
+ | RVGList _ ->
+ generate_java_lvm_return "vg" "VG" vg_cols
+ | RLVList _ ->
+ generate_java_lvm_return "lv" "LV" lv_cols
+ | RHashtable _ ->
+ (* XXX *)
+ pr " throw_exception (env, \"%s: internal error: please let us know how to make a Java HashMap from JNI bindings!\");\n" name;
+ pr " return NULL;\n"
+ );
+
+ pr "}\n";
+ pr "\n"
+ ) all_functions
+
+and generate_java_lvm_return typ jtyp cols =
+ pr " cl = (*env)->FindClass (env, \"com/redhat/et/libguestfs/%s\");\n" jtyp;
+ pr " jr = (*env)->NewObjectArray (env, r->len, cl, NULL);\n";
+ pr " for (i = 0; i < r->len; ++i) {\n";
+ pr " jfl = (*env)->AllocObject (env, cl);\n";
+ List.iter (
+ function
+ | name, `String ->
+ pr " fl = (*env)->GetFieldID (env, cl, \"%s\", \"Ljava/lang/String;\");\n" name;
+ pr " (*env)->SetObjectField (env, jfl, fl, (*env)->NewStringUTF (env, r->val[i].%s));\n" name;
+ | name, `UUID ->
+ pr " {\n";
+ pr " char s[33];\n";
+ pr " memcpy (s, r->val[i].%s, 32);\n" name;
+ pr " s[32] = 0;\n";
+ pr " fl = (*env)->GetFieldID (env, cl, \"%s\", \"Ljava/lang/String;\");\n" name;
+ pr " (*env)->SetObjectField (env, jfl, fl, (*env)->NewStringUTF (env, s));\n";
+ pr " }\n";
+ | name, (`Bytes|`Int) ->
+ pr " fl = (*env)->GetFieldID (env, cl, \"%s\", \"J\");\n" name;
+ pr " (*env)->SetLongField (env, jfl, fl, r->val[i].%s);\n" name;
+ | name, `OptPercent ->
+ pr " fl = (*env)->GetFieldID (env, cl, \"%s\", \"F\");\n" name;
+ pr " (*env)->SetFloatField (env, jfl, fl, r->val[i].%s);\n" name;
+ ) cols;
+ pr " (*env)->SetObjectArrayElement (env, jfl, i, jfl);\n";
+ pr " }\n";
+ pr " guestfs_free_lvm_%s_list (r);\n" typ;
+ pr " return jr;\n"
+
+and generate_haskell_hs () =
+ generate_header HaskellStyle LGPLv2;
+
+ (* XXX We only know how to generate partial FFI for Haskell
+ * at the moment. Please help out!
+ *)
+ let can_generate style =
+ let check_no_bad_args =
+ List.for_all (function Bool _ | Int _ -> false | _ -> true)
+ in
+ match style with
+ | RErr, args -> check_no_bad_args args
+ | RBool _, _
+ | RInt _, _
+ | RInt64 _, _
+ | RConstString _, _
+ | RString _, _
+ | RStringList _, _
+ | RIntBool _, _
+ | RPVList _, _
+ | RVGList _, _
+ | RLVList _, _
+ | RStat _, _
+ | RStatVFS _, _
+ | RHashtable _, _ -> false in
+
+ pr "\
+{-# INCLUDE <guestfs.h> #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+module Guestfs (
+ create";
+
+ (* List out the names of the actions we want to export. *)
+ List.iter (
+ fun (name, style, _, _, _, _, _) ->
+ if can_generate style then pr ",\n %s" name
+ ) all_functions;
+
+ pr "
+ ) where
+import Foreign
+import Foreign.C
+import IO
+import Control.Exception
+import Data.Typeable
+
+data GuestfsS = GuestfsS -- represents the opaque C struct
+type GuestfsP = Ptr GuestfsS -- guestfs_h *
+type GuestfsH = ForeignPtr GuestfsS -- guestfs_h * with attached finalizer
+
+-- XXX define properly later XXX
+data PV = PV
+data VG = VG
+data LV = LV
+data IntBool = IntBool
+data Stat = Stat
+data StatVFS = StatVFS
+data Hashtable = Hashtable
+
+foreign import ccall unsafe \"guestfs_create\" c_create
+ :: IO GuestfsP
+foreign import ccall unsafe \"&guestfs_close\" c_close
+ :: FunPtr (GuestfsP -> IO ())
+foreign import ccall unsafe \"guestfs_set_error_handler\" c_set_error_handler
+ :: GuestfsP -> Ptr CInt -> Ptr CInt -> IO ()
+
+create :: IO GuestfsH
+create = do
+ p <- c_create
+ c_set_error_handler p nullPtr nullPtr
+ h <- newForeignPtr c_close p
+ return h
+
+foreign import ccall unsafe \"guestfs_last_error\" c_last_error
+ :: GuestfsP -> IO CString
+
+-- last_error :: GuestfsH -> IO (Maybe String)
+-- last_error h = do
+-- str <- withForeignPtr h (\\p -> c_last_error p)
+-- maybePeek peekCString str
+
+last_error :: GuestfsH -> IO (String)
+last_error h = do
+ str <- withForeignPtr h (\\p -> c_last_error p)
+ if (str == nullPtr)
+ then return \"no error\"
+ else peekCString str
+
+";
+
+ (* Generate wrappers for each foreign function. *)
+ List.iter (
+ fun (name, style, _, _, _, _, _) ->
+ if can_generate style then (
+ pr "foreign import ccall unsafe \"guestfs_%s\" c_%s\n" name name;
+ pr " :: ";
+ generate_haskell_prototype ~handle:"GuestfsP" style;
+ pr "\n";
+ pr "\n";
+ pr "%s :: " name;
+ generate_haskell_prototype ~handle:"GuestfsH" ~hs:true style;
+ pr "\n";
+ pr "%s %s = do\n" name
+ (String.concat " " ("h" :: List.map name_of_argt (snd style)));
+ pr " r <- ";
+ List.iter (
+ function
+ | FileIn n
+ | FileOut n
+ | String n -> pr "withCString %s $ \\%s -> " n n
+ | OptString n -> pr "maybeWith withCString %s $ \\%s -> " n n
+ | StringList n -> pr "withMany withCString %s $ \\%s -> withArray0 nullPtr %s $ \\%s -> " n n n n
+ | Bool n ->
+ (* XXX this doesn't work *)
+ pr " let\n";
+ pr " %s = case %s of\n" n n;
+ pr " False -> 0\n";
+ pr " True -> 1\n";
+ pr " in fromIntegral %s $ \\%s ->\n" n n
+ | Int n -> pr "fromIntegral %s $ \\%s -> " n n
+ ) (snd style);
+ pr "withForeignPtr h (\\p -> c_%s %s)\n" name
+ (String.concat " " ("p" :: List.map name_of_argt (snd style)));
+ (match fst style with
+ | RErr | RInt _ | RInt64 _ | RBool _ ->
+ pr " if (r == -1)\n";
+ pr " then do\n";
+ pr " err <- last_error h\n";
+ pr " fail err\n";
+ | RConstString _ | RString _ | RStringList _ | RIntBool _
+ | RPVList _ | RVGList _ | RLVList _ | RStat _ | RStatVFS _
+ | RHashtable _ ->
+ pr " if (r == nullPtr)\n";
+ pr " then do\n";
+ pr " err <- last_error h\n";
+ pr " fail err\n";
+ );
+ (match fst style with
+ | RErr ->
+ pr " else return ()\n"
+ | RInt _ ->
+ pr " else return (fromIntegral r)\n"
+ | RInt64 _ ->
+ pr " else return (fromIntegral r)\n"
+ | RBool _ ->
+ pr " else return (toBool r)\n"
+ | RConstString _
+ | RString _
+ | RStringList _
+ | RIntBool _
+ | RPVList _
+ | RVGList _
+ | RLVList _
+ | RStat _
+ | RStatVFS _
+ | RHashtable _ ->
+ pr " else return ()\n" (* XXXXXXXXXXXXXXXXXXXX *)
+ );
+ pr "\n";
+ )
+ ) all_functions
+
+and generate_haskell_prototype ~handle ?(hs = false) style =
+ pr "%s -> " handle;
+ let string = if hs then "String" else "CString" in
+ let int = if hs then "Int" else "CInt" in
+ let bool = if hs then "Bool" else "CInt" in
+ let int64 = if hs then "Integer" else "Int64" in
+ List.iter (
+ fun arg ->
+ (match arg with
+ | String _ -> pr "%s" string
+ | OptString _ -> if hs then pr "Maybe String" else pr "CString"
+ | StringList _ -> if hs then pr "[String]" else pr "Ptr CString"
+ | Bool _ -> pr "%s" bool
+ | Int _ -> pr "%s" int
+ | FileIn _ -> pr "%s" string
+ | FileOut _ -> pr "%s" string
+ );
+ pr " -> ";
+ ) (snd style);
+ pr "IO (";
+ (match fst style with
+ | RErr -> if not hs then pr "CInt"
+ | RInt _ -> pr "%s" int
+ | RInt64 _ -> pr "%s" int64
+ | RBool _ -> pr "%s" bool
+ | RConstString _ -> pr "%s" string
+ | RString _ -> pr "%s" string
+ | RStringList _ -> pr "[%s]" string
+ | RIntBool _ -> pr "IntBool"
+ | RPVList _ -> pr "[PV]"
+ | RVGList _ -> pr "[VG]"
+ | RLVList _ -> pr "[LV]"
+ | RStat _ -> pr "Stat"
+ | RStatVFS _ -> pr "StatVFS"
+ | RHashtable _ -> pr "Hashtable"
+ );
+ pr ")"
+