mirrors/libguestfs
1
0
Fork 0
mirror of https://github.com/libguestfs/libguestfs.git synced 2026-03-22 07:03:38 +00:00
Code Issues Packages Projects Releases Wiki Activity

daemon: Allow parts of the daemon and APIs to be written in OCaml.

Browse Source 
This change allows parts of the daemon to be written in the OCaml
programming language.  I am using the ‘Main Program in C’ method along
with ‘-output-obj’ to create an object file from the OCaml code /
runtime, as described here:
https://caml.inria.fr/pub/docs/manual-ocaml/intfc.html

Furthermore, change the generator to allow individual APIs to be
implemented in OCaml.  This is picked by setting:

  impl = OCaml <ocaml_function>;

The generator creates ‘do_function’ (the same one you would have to
write by hand in C), with the function calling the named
‘ocaml_function’ and dealing with marshalling/unmarshalling the OCaml
parameters.
This commit is contained in:
Richard W.M. Jones
2017-06-02 17:09:29 +01:00
parent 10cf01419a
commit d5b6f1df5f
25 changed files with 1221 additions and 16 deletions
Download Patch File Download Diff File Expand all files Collapse all files

8
.gitignore vendored
View File

@@ -165,20 +165,26 @@ Makefile.in
/customize/test-settings-*.sh
/customize/virt-customize
/customize/virt-customize.1
/daemon/.depend
/daemon/actions.h
/daemon/callbacks.ml
/daemon/caml-stubs.c
/daemon/dispatch.c
/daemon/guestfsd
/daemon/guestfsd.8
/daemon/guestfsd.exe
/daemon/lvm-tokenization.c
/daemon/names.c
/daemon/optgroups.c
/daemon/optgroups.h
/daemon/lvm-tokenization.c
/daemon/optgroups.ml
/daemon/stamp-guestfsd.pod
/daemon/structs-cleanups.c
/daemon/structs-cleanups.h
/daemon/structs.ml
/daemon/stubs-?.c
/daemon/stubs.h
/daemon/types.ml
/depcomp
/df/stamp-virt-df.pod
/df/virt-df

2
Makefile.am
View File

@@ -44,6 +44,7 @@ SUBDIRS += common/structs
SUBDIRS += lib docs examples po
# The daemon and the appliance.
SUBDIRS += common/mlutils
if ENABLE_DAEMON
SUBDIRS += daemon
SUBDIRS += tests/daemon
@@ -155,7 +156,6 @@ SUBDIRS += csharp
# OCaml tools. Note 'common/ml*', 'mllib' and 'customize' contain
# shared code used by other OCaml tools, so these must come first.
if HAVE_OCAML
SUBDIRS += common/mlutils
SUBDIRS += common/mlprogress
SUBDIRS += common/mlvisit
SUBDIRS += common/mlxml

4
common/mlutils/Makefile.am
View File

@@ -35,8 +35,6 @@ SOURCES_C = \
c_utils-c.c \
unix_utils-c.c
if HAVE_OCAML
# We pretend that we're building a C library. automake handles the
# compilation of the C sources for us. At the end we take the C
# objects and OCaml objects and link them into the OCaml library.
@@ -150,6 +148,4 @@ depend: .depend
-include .depend
endif
.PHONY: depend docs

94
daemon/Makefile.am
View File

@@ -17,8 +17,9 @@
include $(top_srcdir)/subdir-rules.mk
generator_built = \
BUILT_SOURCES = \
actions.h \
caml-stubs.c \
dispatch.c \
names.c \
lvm-tokenization.c \
@@ -33,11 +34,14 @@ generator_built = \
stubs-6.c \
stubs.h
BUILT_SOURCES = \
$(generator_built)
generator_built = \
$(BUILT_SOURCES) \
callbacks.ml \
types.ml
EXTRA_DIST = \
$(BUILT_SOURCES) \
$(generator_built) \
$(SOURCES_MLI) $(SOURCES_ML) \
guestfsd.pod
if INSTALL_DAEMON
@@ -61,6 +65,7 @@ guestfsd_SOURCES = \
blkid.c \
blockdev.c \
btrfs.c \
caml-stubs.c \
cap.c \
checksum.c \
cleanups.c \
@@ -71,6 +76,8 @@ guestfsd_SOURCES = \
copy.c \
cpio.c \
cpmv.c \
daemon-c.c \
daemon-c.h \
daemon.h \
dd.c \
debug.c \
@@ -161,6 +168,7 @@ guestfsd_SOURCES = \
swap.c \
sync.c \
syslinux.c \
sysroot-c.c \
tar.c \
tsk.c \
truncate.c \
@@ -176,10 +184,16 @@ guestfsd_SOURCES = \
zero.c \
zerofree.c
guestfsd_LDFLAGS = \
-L$(shell $(OCAMLC) -where) \
-L$(shell $(OCAMLC) -where)/hivex \
-L../common/mlutils \
-L../common/mlstdutils
guestfsd_LDADD = \
../common/errnostring/liberrnostring.la \
../common/protocol/libprotocol.la \
../common/utils/libutils.la \
camldaemon.o \
$(ACL_LIBS) \
$(CAP_LIBS) \
$(YAJL_LIBS) \
@@ -198,9 +212,12 @@ guestfsd_LDADD = \
$(PCRE_LIBS) \
$(TSK_LIBS) \
$(RPC_LIBS) \
$(YARA_LIBS)
$(YARA_LIBS) \
$(OCAML_LIBS)
guestfsd_CPPFLAGS = \
-I$(shell $(OCAMLC) -where) \
-I$(shell $(OCAMLC) -where)/hivex \
-I$(top_srcdir)/gnulib/lib \
-I$(top_builddir)/gnulib/lib \
-I$(top_srcdir)/lib \
@@ -220,6 +237,71 @@ guestfsd_CFLAGS = \
$(YAJL_CFLAGS) \
$(PCRE_CFLAGS)
# Parts of the daemon are written in OCaml. These are linked into a
# library and then linked to the daemon. See
# https://caml.inria.fr/pub/docs/manual-ocaml/intfc.html
SOURCES_MLI = \
chroot.mli \
sysroot.mli \
utils.mli
SOURCES_ML = \
types.ml \
utils.ml \
structs.ml \
optgroups.ml \
sysroot.ml \
chroot.ml \
callbacks.ml \
daemon.ml
BOBJECTS = $(SOURCES_ML:.ml=.cmo)
XOBJECTS = $(BOBJECTS:.cmo=.cmx)
OCAMLPACKAGES = \
-package str,unix,hivex \
-I $(top_srcdir)/common/mlstdutils \
-I $(top_srcdir)/common/mlutils
OCAMLFLAGS = $(OCAML_FLAGS) $(OCAML_WARN_FLAGS)
if !HAVE_OCAMLOPT
OBJECTS = $(BOBJECTS)
CAMLRUN = camlrun
else
OBJECTS = $(XOBJECTS)
CAMLRUN = asmrun
endif
OCAML_LIBS = \
-lmlcutils \
-lmlstdutils \
-lmlhivex \
-lcamlstr \
-lunix \
-l$(CAMLRUN) -ldl -lm
CLEANFILES += camldaemon.o
camldaemon.o: $(OBJECTS)
$(OCAMLFIND) $(BEST) -output-obj -o $@ \
$(OCAMLFLAGS) $(OCAMLPACKAGES) \
-linkpkg mlcutils.$(MLARCHIVE) mlstdutils.$(MLARCHIVE) \
$(OBJECTS)
# OCaml dependencies.
depend: .depend
.depend: $(wildcard $(abs_srcdir)/*.mli) $(wildcard $(abs_srcdir)/*.ml)
rm -f $@ $@-t
$(OCAMLFIND) ocamldep -I $(abs_srcdir) -I $(abs_top_builddir)/common/mlstdutils -I $(abs_top_builddir)/common/mlutils $^ | \
$(SED) 's/ *$$//' | \
$(SED) -e :a -e '/ *\\$$/N; s/ *\\\n */ /; ta' | \
$(SED) -e 's,$(abs_srcdir)/,$(builddir)/,g' | \
sort > $@-t
mv $@-t $@
-include .depend
# Manual pages and HTML files for the website.
if INSTALL_DAEMON
man_MANS = guestfsd.8
@@ -241,4 +323,4 @@ stamp-guestfsd.pod: guestfsd.pod
$<
touch $@
.PHONY: force
.PHONY: depend force

85
daemon/chroot.ml Normal file
View File

@@ -0,0 +1,85 @@
(* guestfs-inspection
* Copyright (C) 2009-2017 Red Hat Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License along
* with this program; if not, write to the Free Software Foundation, Inc.,
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
*)
open Printf
open Unix
open Std_utils
open Unix_utils
type t = {
name : string;
chroot : string;
}
let create ?(name = "<unnamed>") ?(chroot = Sysroot.sysroot ()) () =
{ name = name; chroot = chroot }
let f t func arg =
if verbose () then
eprintf "chroot: %s: running '%s'\n%!" t.chroot t.name;
let rfd, wfd = pipe () in
let pid = fork () in
if pid = 0 then (
(* Child. *)
close rfd;
chdir t.chroot;
chroot t.chroot;
let ret =
try Either (func arg)
with exn -> Or exn in
try
let chan = out_channel_of_descr wfd in
output_value chan ret;
Pervasives.flush chan;
Exit._exit 0
with
exn ->
prerr_endline (Printexc.to_string exn);
Exit._exit 1
);
(* Parent. *)
close wfd;
let _, status = waitpid [] pid in
(match status with
| WEXITED 0 -> ()
| WEXITED i ->
close rfd;
failwithf "chroot ‘%s’ exited with non-zero error %d" t.name i
| WSIGNALED i ->
close rfd;
failwithf "chroot ‘%s’ killed by signal %d" t.name i
| WSTOPPED i ->
close rfd;
failwithf "chroot ‘%s’ stopped by signal %d" t.name i
);
let chan = in_channel_of_descr rfd in
let ret = input_value chan in
close_in chan;
match ret with
| Either ret -> ret
| Or exn -> raise exn

38
daemon/chroot.mli Normal file
View File

@@ -0,0 +1,38 @@
(* guestfs-inspection
* Copyright (C) 2009-2017 Red Hat Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License along
* with this program; if not, write to the Free Software Foundation, Inc.,
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
*)
(** This is a generic module for running functions in a chroot.
The function runs in a forked subprocess too so that we can
restore the root afterwards.
It handles passing the parameter, forking, running the
function and marshalling the result or any exceptions. *)
type t
val create : ?name:string -> ?chroot:string -> unit -> t
(** Create a chroot handle.
[?name] is an optional name used in debugging and error messages.
[?chroot] is the optional chroot directory. This parameter
defaults to [Sysroot.sysroot ()]. *)
val f : t -> ('a -> 'b) -> 'a -> 'b
(** Run a function in the chroot, returning the result or re-raising
any exception thrown. *)

203
daemon/daemon-c.c Normal file
View File

@@ -0,0 +1,203 @@
/* guestfs-inspection
* Copyright (C) 2017 Red Hat Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
*/
#include <config.h>
#include <stdio.h>
#include <stdlib.h>
#include <caml/alloc.h>
#include <caml/mlvalues.h>
#include <caml/memory.h>
#include <caml/unixsupport.h>
#include "daemon.h"
#include "daemon-c.h"
/* Convert an OCaml exception to a reply_with_error_errno call
* as best we can.
*/
void
guestfs_int_daemon_exn_to_reply_with_error (const char *func, value exn)
{
const char *exn_name;
/* This is not the official way to do this, but I could not get the
* official way to work, and this way does work. See
* http://caml.inria.fr/pub/ml-archives/caml-list/2006/05/097f63cfb39a80418f95c70c3c520aa8.en.html
* http://caml.inria.fr/pub/ml-archives/caml-list/2009/06/797e2f797f57b8ea2a2c0e431a2df312.en.html
*/
if (Tag_val (Field (exn, 0)) == String_tag)
/* For End_of_file and a few other constant exceptions. */
exn_name = String_val (Field (exn, 0));
else
/* For most exceptions. */
exn_name = String_val (Field (Field (exn, 0), 0));
if (verbose)
fprintf (stderr, "ocaml_exn: '%s' raised '%s' exception\n",
func, exn_name);
if (STREQ (exn_name, "Unix.Unix_error")) {
int errcode = code_of_unix_error (Field (exn, 1));
reply_with_perror_errno (errcode, "%s: %s",
String_val (Field (exn, 2)),
String_val (Field (exn, 3)));
}
else if (STREQ (exn_name, "Failure"))
reply_with_error ("%s", String_val (Field (exn, 1)));
else if (STREQ (exn_name, "Sys_error"))
reply_with_error ("%s", String_val (Field (exn, 1)));
else if (STREQ (exn_name, "Invalid_argument"))
reply_with_error ("invalid argument: %s", String_val (Field (exn, 1)));
else
reply_with_error ("internal error: %s: unhandled exception thrown: %s",
func, exn_name);
}
/* NB: This is a "noalloc" call. */
value
guestfs_int_daemon_get_verbose_flag (value unitv)
{
return Val_bool (verbose);
}
/* Implement String (Mountable, _) parameter. */
value
guestfs_int_daemon_copy_mountable (const mountable_t *mountable)
{
CAMLparam0 ();
CAMLlocal4 (r, typev, devicev, volumev);
switch (mountable->type) {
case MOUNTABLE_DEVICE:
typev = Val_int (0); /* MountableDevice */
break;
case MOUNTABLE_PATH:
typev = Val_int (1); /* MountablePath */
break;
case MOUNTABLE_BTRFSVOL:
volumev = caml_copy_string (mountable->volume);
typev = caml_alloc (1, 0); /* MountableBtrfsVol */
Store_field (typev, 0, volumev);
}
devicev = caml_copy_string (mountable->device);
r = caml_alloc_tuple (2);
Store_field (r, 0, typev);
Store_field (r, 1, devicev);
CAMLreturn (r);
}
/* Implement RStringList. */
char **
guestfs_int_daemon_return_string_list (value retv)
{
CLEANUP_FREE_STRINGSBUF DECLARE_STRINGSBUF (ret);
value v;
while (retv != Val_int (0)) {
v = Field (retv, 0);
if (add_string (&ret, String_val (v)) == -1)
return NULL;
retv = Field (retv, 1);
}
if (end_stringsbuf (&ret) == -1)
return NULL;
return take_stringsbuf (&ret); /* caller frees */
}
/* Implement RString (RMountable, _). */
char *
guestfs_int_daemon_return_string_mountable (value retv)
{
value typev = Field (retv, 0);
value devicev = Field (retv, 1);
value subvolv;
char *ret;
if (Is_long (typev)) { /* MountableDevice or MountablePath */
ret = strdup (String_val (devicev));
if (ret == NULL)
reply_with_perror ("strdup");
return ret;
}
else { /* MountableBtrfsVol of subvol */
subvolv = Field (typev, 0);
if (asprintf (&ret, "btrfsvol:%s/%s",
String_val (devicev), String_val (subvolv)) == -1)
reply_with_perror ("asprintf");
return ret;
}
}
/* Implement RHashtable (RPlainString, RPlainString, _). */
char **
guestfs_int_daemon_return_hashtable_string_string (value retv)
{
CLEANUP_FREE_STRINGSBUF DECLARE_STRINGSBUF (ret);
value v, sv;
while (retv != Val_int (0)) {
v = Field (retv, 0); /* (string, string) */
sv = Field (v, 0); /* string */
if (add_string (&ret, String_val (sv)) == -1)
return NULL;
sv = Field (v, 1); /* string */
if (add_string (&ret, String_val (sv)) == -1)
return NULL;
retv = Field (retv, 1);
}
if (end_stringsbuf (&ret) == -1)
return NULL;
return take_stringsbuf (&ret); /* caller frees */
}
/* Implement RHashtable (RMountable, RPlainString, _). */
char **
guestfs_int_daemon_return_hashtable_mountable_string (value retv)
{
CLEANUP_FREE_STRINGSBUF DECLARE_STRINGSBUF (ret);
value v, mv, sv;
char *m;
while (retv != Val_int (0)) {
v = Field (retv, 0); /* (Mountable.t, string) */
mv = Field (v, 0); /* Mountable.t */
m = guestfs_int_daemon_return_string_mountable (mv);
if (m == NULL)
return NULL;
if (add_string_nodup (&ret, m) == -1)
return NULL;
sv = Field (v, 1); /* string */
if (add_string (&ret, String_val (sv)) == -1)
return NULL;
retv = Field (retv, 1);
}
if (end_stringsbuf (&ret) == -1)
return NULL;
return take_stringsbuf (&ret); /* caller frees */
}

38
daemon/daemon-c.h Normal file
View File

@@ -0,0 +1,38 @@
/* guestfs-inspection
* Copyright (C) 2017 Red Hat Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
*/
/* This file is separate from <daemon.h> because we don't want to
* include the OCaml headers (to get 'value') for the whole daemon.
*/
#ifndef GUESTFSD_DAEMON_C_H
#define GUESTFSD_DAEMON_C_H
#include "daemon.h"
#include <caml/mlvalues.h>
extern value guestfs_int_daemon_get_verbose_flag (value unitv);
extern void guestfs_int_daemon_exn_to_reply_with_error (const char *func, value exn);
extern value guestfs_int_daemon_copy_mountable (const mountable_t *mountable);
extern char **guestfs_int_daemon_return_string_list (value retv);
extern char *guestfs_int_daemon_return_string_mountable (value retv);
extern char **guestfs_int_daemon_return_hashtable_string_string (value retv);
extern char **guestfs_int_daemon_return_hashtable_mountable_string (value retv);
#endif /* GUESTFSD_DAEMON_C_H */

41
daemon/daemon.ml Normal file
View File

@@ -0,0 +1,41 @@
(* guestfs-inspection
* Copyright (C) 2009-2017 Red Hat Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License along
* with this program; if not, write to the Free Software Foundation, Inc.,
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
*)
open Printf
external get_verbose_flag : unit -> bool =
"guestfs_int_daemon_get_verbose_flag" "noalloc"
(* When guestfsd starts up, early on (after parsing the command line
* but not much else), it calls 'caml_startup' which runs all
* initialization code in the OCaml modules, including this one.
*
* Therefore this is where we can place OCaml initialization code
* for the daemon.
*)
let () =
(* Connect the guestfsd [-v] (verbose) flag into 'verbose ()'
* used in OCaml code to print debugging messages.
*)
if get_verbose_flag () then (
Std_utils.set_verbose ();
eprintf "OCaml daemon loaded\n%!"
);
(* Register the callbacks which are used to call OCaml code from C. *)
Callbacks.init_callbacks ()

8
daemon/guestfsd.c
View File

@@ -56,6 +56,8 @@
#include <augeas.h>
#include <caml/callback.h> /* for caml_startup */
#include "sockets.h"
#include "c-ctype.h"
#include "ignore-value.h"
@@ -231,6 +233,12 @@ main (int argc, char *argv[])
exit (EXIT_FAILURE);
}
/* Initialize the OCaml stubs. This must be done after the
* ‘verbose’ flag is set from the command line since the OCaml
* initialization code depends on that.
*/
caml_startup (argv);
#ifndef WIN32
/* Make sure SIGPIPE doesn't kill us. */
struct sigaction sa;

37
daemon/sysroot-c.c Normal file
View File

@@ -0,0 +1,37 @@
/* guestfs-inspection
* Copyright (C) 2017 Red Hat Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
*/
#include <config.h>
#include <stdio.h>
#include <stdlib.h>
#include <caml/alloc.h>
#include <caml/fail.h>
#include <caml/memory.h>
#include <caml/mlvalues.h>
#include "daemon.h"
extern value guestfs_int_daemon_sysroot (value unitv);
value
guestfs_int_daemon_sysroot (value unitv)
{
return caml_copy_string (sysroot);
}

23
daemon/sysroot.ml Normal file
View File

@@ -0,0 +1,23 @@
(* guestfs-inspection
* Copyright (C) 2009-2017 Red Hat Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License along
* with this program; if not, write to the Free Software Foundation, Inc.,
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
*)
open Std_utils
external sysroot : unit -> string = "guestfs_int_daemon_sysroot"
let sysroot_path path = sysroot () // path

25
daemon/sysroot.mli Normal file
View File

@@ -0,0 +1,25 @@
(* guestfs-inspection
* Copyright (C) 2009-2017 Red Hat Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License along
* with this program; if not, write to the Free Software Foundation, Inc.,
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
*)
val sysroot : unit -> string
(** Return the current sysroot path where filesystems are mounted.
This comes from the daemon command line ([-r] option) or a built
in default. *)
val sysroot_path : string -> string
(** Equivalent to calling [sysroot () // path] *)

158
daemon/utils.ml Normal file
View File

@@ -0,0 +1,158 @@
(* guestfs-inspection
* Copyright (C) 2009-2017 Red Hat Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License along
* with this program; if not, write to the Free Software Foundation, Inc.,
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
*)
open Unix
open Printf
open Std_utils
let prog_exists prog =
try ignore (which prog); true
with Executable_not_found _ -> false
let commandr ?(fold_stdout_on_stderr = false) prog args =
if verbose () then
eprintf "command: %s %s\n%!"
(if fold_stdout_on_stderr then " fold-stdout-on-stderr" else "")
(stringify_args (prog :: args));
let argv = Array.of_list (prog :: args) in
let stdout_file, stdout_chan = Filename.open_temp_file "cmd" ".out" in
let stderr_file, stderr_chan = Filename.open_temp_file "cmd" ".err" in
let stdout_fd = descr_of_out_channel stdout_chan in
let stderr_fd = descr_of_out_channel stderr_chan in
let stdin_fd = openfile "/dev/null" [O_RDONLY] 0 in
let pid = fork () in
if pid = 0 then (
(* Child process. *)
dup2 stdin_fd stdin;
close stdin_fd;
if not fold_stdout_on_stderr then
dup2 stdout_fd stdout
else
dup2 stderr_fd stdout;
close stdout_fd;
dup2 stderr_fd stderr;
close stderr_fd;
execvp prog argv
);
(* Parent process. *)
close stdin_fd;
close stdout_fd;
close stderr_fd;
let _, status = waitpid [] pid in
let r =
match status with
| WEXITED i -> i
| WSIGNALED i ->
failwithf "external command ‘%s’ killed by signal %d" prog i
| WSTOPPED i ->
failwithf "external command ‘%s’ stopped by signal %d" prog i in
if verbose () then
eprintf "command: %s returned %d\n" prog r;
let stdout = read_whole_file stdout_file in
let stderr = read_whole_file stderr_file in
(try unlink stdout_file with _ -> ());
(try unlink stderr_file with _ -> ());
if verbose () then (
if stdout <> "" then (
eprintf "command: %s: stdout:\n%s%!" prog stdout;
if not (String.is_suffix stdout "\n") then eprintf "\n%!"
);
if stderr <> "" then (
eprintf "command: %s: stderr:\n%s%!" prog stderr;
if not (String.is_suffix stderr "\n") then eprintf "\n%!"
)
);
(* Strip trailing \n from stderr but NOT from stdout. *)
let stderr = String.chomp stderr in
(r, stdout, stderr)
let command ?fold_stdout_on_stderr prog args =
let r, stdout, stderr = commandr ?fold_stdout_on_stderr prog args in
if r <> 0 then
failwithf "%s exited with status %d: %s" prog r stderr;
stdout
let udev_settle ?filename () =
let args = ref [] in
if verbose () then
push_back args "--debug";
push_back args "settle";
(match filename with
| None -> ()
| Some filename ->
push_back args "-E";
push_back args filename
);
let args = !args in
let r, _, err = commandr "udevadm" args in
if r <> 0 then
eprintf "udevadm settle: %s\n" err
let root_device = lazy ((stat "/").st_dev)
let is_root_device_stat statbuf =
statbuf.st_rdev = Lazy.force root_device
let is_root_device device =
udev_settle ~filename:device ();
try
let statbuf = stat device in
is_root_device_stat statbuf
with
Unix_error (err, func, arg) ->
eprintf "is_root_device: %s: %s: %s: %s\n"
device func arg (error_message err);
false
let proc_unmangle_path path =
let n = String.length path in
let b = Buffer.create n in
let rec loop i =
if i < n-3 && path.[i] = '\\' then (
let to_int c = Char.code c - Char.code '0' in
let v =
(to_int path.[i+1] lsl 6) lor
(to_int path.[i+2] lsl 3) lor
to_int path.[i+3] in
Buffer.add_char b (Char.chr v);
loop (i+4)
)
else if i < n then (
Buffer.add_char b path.[i];
loop (i+1)
)
else
Buffer.contents b
in
loop 0
let is_small_file path =
is_regular_file path &&
(stat path).st_size <= 2 * 1048 * 1024

72
daemon/utils.mli Normal file
View File

@@ -0,0 +1,72 @@
(* guestfs-inspection
* Copyright (C) 2009-2017 Red Hat Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License along
* with this program; if not, write to the Free Software Foundation, Inc.,
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
*)
val prog_exists : string -> bool
(** Return true iff the program is found on [$PATH]. *)
val udev_settle : ?filename:string -> unit -> unit
(**
* LVM and other commands aren't synchronous, especially when udev is
* involved. eg. You can create or remove some device, but the
* [/dev] device node won't appear until some time later. This means
* that you get an error if you run one command followed by another.
*
* Use [udevadm settle] after certain commands, but don't be too
* fussed if it fails.
*
* The optional [?filename] passes the [udevadm settle -E filename]
* option, which means udevadm stops waiting as soon as the named
* file is created (or if it exists at the start).
*)
val is_root_device : string -> bool
(** Return true if this is the root (appliance) device. *)
val is_root_device_stat : Unix.stats -> bool
(** As for {!is_root_device} but operates on a statbuf instead of
a device name. *)
val proc_unmangle_path : string -> string
(** Reverse kernel path escaping done in fs/seq_file.c:mangle_path.
This is inconsistently used for /proc fields. *)
val command : ?fold_stdout_on_stderr:bool -> string -> string list -> string
(** Run an external command without using the shell, and collect
stdout and stderr separately. Returns stdout if the command
runs successfully.
On failure of the command, this throws an exception containing
the stderr from the command.
[?fold_stdout_on_stderr] (default: false)
For broken external commands that send error messages to stdout
(hello, parted) but that don't have any useful stdout information,
use this flag to capture the error messages in the [stderr]
buffer. Nothing will be captured on stdout if you use this flag. *)
val commandr : ?fold_stdout_on_stderr:bool -> string -> string list -> (int * string * string)
(** Run an external command without using the shell, and collect
stdout and stderr separately.
Returns [status, stdout, stderr]. As with the C function in
[daemon/command.c], this strips the trailing [\n] from stderr,
but {b not} from stdout. *)
val is_small_file : string -> bool
(** Return true if the path is a small regular file. *)

4
docs/C_SOURCE_FILES
View File

@@ -72,6 +72,7 @@ daemon/blkdiscard.c
daemon/blkid.c
daemon/blockdev.c
daemon/btrfs.c
daemon/caml-stubs.c
daemon/cap.c
daemon/checksum.c
daemon/cleanups.c
@@ -82,6 +83,8 @@ daemon/compress.c
daemon/copy.c
daemon/cpio.c
daemon/cpmv.c
daemon/daemon-c.c
daemon/daemon-c.h
daemon/daemon.h
daemon/dd.c
daemon/debug-bmap.c
@@ -172,6 +175,7 @@ daemon/stubs.h
daemon/swap.c
daemon/sync.c
daemon/syslinux.c
daemon/sysroot-c.c
daemon/tar.c
daemon/truncate.c
daemon/tsk.c

7
docs/guestfs-hacking.pod
View File

@@ -416,6 +416,13 @@ in the C<lib/> directory.
In either case, use another function as an example of what to do.
=item 3.
As an alternative to step 2: Since libguestfs 1.38, daemon actions
can be implemented in OCaml. You have to set the C<impl = OCaml ...>
flag in the generator. Take a look at F<daemon/file.ml> for an
example.
=back
After making these changes, use C<make> to compile.

8
generator/OCaml.ml
View File

@@ -888,3 +888,11 @@ and generate_ocaml_function_type ?(extra_unit = false) (ret, args, optargs) =
| RStructList (_, typ) -> pr "%s array" typ
| RHashtable _ -> pr "(string * string) list"
)
(* Structure definitions (again). These are used in the daemon,
* but it's convenient to generate them here.
*)
and generate_ocaml_daemon_structs () =
generate_header OCamlStyle GPLv2plus;
generate_ocaml_structure_decls ()

1
generator/OCaml.mli
View File

@@ -20,3 +20,4 @@ val generate_ocaml_c : unit -> unit
val generate_ocaml_c_errnos : unit -> unit
val generate_ocaml_ml : unit -> unit
val generate_ocaml_mli : unit -> unit
val generate_ocaml_daemon_structs : unit -> unit

5
generator/actions.ml
View File

@@ -185,6 +185,11 @@ let is_fish { visibility = v; style = (_, args, _) } =
not (List.exists (function Pointer _ -> true | _ -> false) args)
let fish_functions = List.filter is_fish
let is_ocaml_function = function
| { impl = OCaml _ } -> true
| { impl = C } -> false
let impl_ocaml_functions = List.filter is_ocaml_function
(* In some places we want the functions to be displayed sorted
* alphabetically, so this is useful:
*)

4
generator/actions.mli
View File

@@ -40,6 +40,10 @@ val internal_functions : Types.action list -> Types.action list
val fish_functions : Types.action list -> Types.action list
(** Filter {!actions}, returning only functions in guestfish. *)
val impl_ocaml_functions : Types.action list -> Types.action list
(** Filter {!actions}, returning only functions implemented
in OCaml (in the daemon). *)
val documented_functions : Types.action list -> Types.action list
(** Filter {!actions}, returning only functions requiring documentation. *)

351
generator/daemon.ml
View File

@@ -471,6 +471,324 @@ let generate_daemon_stubs actions () =
pr "}\n\n";
) (actions |> daemon_functions |> sort)
let generate_daemon_caml_types_ml () =
generate_header OCamlStyle GPLv2plus
let generate_daemon_caml_callbacks_ml () =
generate_header OCamlStyle GPLv2plus;
if actions |> impl_ocaml_functions <> [] then (
pr "let init_callbacks () =\n";
pr " (* Initialize callbacks to OCaml code. *)\n";
List.iter (
fun ({ name = name; style = ret, args, optargs } as f) ->
let ocaml_function =
match f.impl with
| OCaml f -> f
| C -> assert false in
pr " Callback.register %S %s;\n" ocaml_function ocaml_function
) (actions |> impl_ocaml_functions |> sort)
)
else
pr "let init_callbacks () = ()\n"
(* Generate stubs for the functions implemented in OCaml.
* Basically we implement the do_<name> function here, and
* have it call out to OCaml code.
*)
let generate_daemon_caml_stubs () =
generate_header CStyle GPLv2plus;
pr "\
#include <config.h>
#include <stdio.h>
#include <stdlib.h>
#include <stdbool.h>
#include <string.h>
#include <inttypes.h>
#include <errno.h>
#include <caml/alloc.h>
#include <caml/callback.h>
#include <caml/fail.h>
#include <caml/memory.h>
#include <caml/mlvalues.h>
#include \"daemon.h\"
#include \"actions.h\"
#include \"daemon-c.h\"
";
(* Implement code for returning structs and struct lists. *)
let emit_return_struct typ =
let struc = Structs.lookup_struct typ in
pr "/* Implement RStruct (%S, _). */\n" typ;
pr "static guestfs_int_%s *\n" typ;
pr "return_%s (value retv)\n" typ;
pr "{\n";
pr " guestfs_int_%s *ret;\n" typ;
pr " value v;\n";
pr "\n";
pr " ret = malloc (sizeof (*ret));\n";
pr " if (ret == NULL) {\n";
pr " reply_with_perror (\"malloc\");\n";
pr " return NULL;\n";
pr " }\n";
pr "\n";
iteri (
fun i ->
pr " v = Field (retv, %d);\n" i;
function
| n, (FString|FUUID) ->
pr " ret->%s = strdup (String_val (v));\n" n;
pr " if (ret->%s == NULL) return NULL;\n" n
| n, FBuffer ->
pr " ret->%s_len = caml_string_length (v);\n" n;
pr " ret->%s = strdup (String_val (v));\n" n;
pr " if (ret->%s == NULL) return NULL;\n" n
| n, (FBytes|FInt64|FUInt64) ->
pr " ret->%s = Int64_val (v);\n" n
| n, (FInt32|FUInt32) ->
pr " ret->%s = Int32_val (v);\n" n
| n, FOptPercent ->
pr " if (v == Val_int (0)) /* None */\n";
pr " ret->%s = -1;\n" n;
pr " else {\n";
pr " v = Field (v, 0);\n";
pr " ret->%s = Double_val (v);\n" n;
pr " }\n"
| n, FChar ->
pr " ret->%s = Int_val (v);\n" n
) struc.s_cols;
pr "\n";
pr " return ret;\n";
pr "}\n";
pr "\n"
and emit_return_struct_list typ =
pr "/* Implement RStructList (%S, _). */\n" typ;
pr "static guestfs_int_%s_list *\n" typ;
pr "return_%s_list (value retv)\n" typ;
pr "{\n";
pr " guestfs_int_%s_list *ret;\n" typ;
pr " guestfs_int_%s *r;\n" typ;
pr " size_t i, len;\n";
pr " value v, rv;\n";
pr "\n";
pr " /* Count the number of elements in the list. */\n";
pr " rv = retv;\n";
pr " len = 0;\n";
pr " while (rv != Val_int (0)) {\n";
pr " len++;\n";
pr " rv = Field (rv, 1);\n";
pr " }\n";
pr "\n";
pr " ret = malloc (sizeof *ret);\n";
pr " if (ret == NULL) {\n";
pr " reply_with_perror (\"malloc\");\n";
pr " return NULL;\n";
pr " }\n";
pr " ret->guestfs_int_%s_list_len = len;\n" typ;
pr " ret->guestfs_int_%s_list_val =\n" typ;
pr " calloc (len, sizeof (guestfs_int_%s));\n" typ;
pr " if (ret->guestfs_int_%s_list_val == NULL) {\n" typ;
pr " reply_with_perror (\"calloc\");\n";
pr " free (ret);\n";
pr " return NULL;\n";
pr " }\n";
pr "\n";
pr " rv = retv;\n";
pr " for (i = 0; i < len; ++i) {\n";
pr " v = Field (rv, 0);\n";
pr " r = return_%s (v);\n" typ;
pr " if (r == NULL)\n";
pr " return NULL; /* XXX leaks memory along this error path */\n";
pr " memcpy (&ret->guestfs_int_%s_list_val[i], r, sizeof (*r));\n" typ;
pr " free (r);\n";
pr " rv = Field (rv, 1);\n";
pr " }\n";
pr "\n";
pr " return ret;\n";
pr "}\n";
pr "\n";
in
List.iter (
function
| typ, RStructOnly ->
emit_return_struct typ
| typ, (RStructListOnly | RStructAndList) ->
emit_return_struct typ;
emit_return_struct_list typ
) (rstructs_used_by (actions |> impl_ocaml_functions));
(* Implement the wrapper functions. *)
List.iter (
fun ({ name = name; style = ret, args, optargs } as f) ->
let uc_name = String.uppercase_ascii name in
let ocaml_function =
match f.impl with
| OCaml f -> f
| C -> assert false in
pr "/* Wrapper for OCaml function ‘%s’. */\n" ocaml_function;
let args_do_function = args @ args_of_optargs optargs in
let args_do_function =
List.filter (function
| String ((FileIn|FileOut), _) -> false | _ -> true)
args_do_function in
let style = ret, args_do_function, [] in
generate_prototype ~extern:false ~semicolon:false
~single_line:false ~newline:false
~in_daemon:true ~prefix:"do_"
name style;
pr "\n";
let add_unit_arg =
let args = List.filter
(function
| String ((FileIn|FileOut), _) -> false | _ -> true)
args in
args = [] in
let nr_args = List.length args_do_function in
pr "{\n";
pr " static value *cb = NULL;\n";
pr " CAMLparam0 ();\n";
pr " CAMLlocal2 (v, retv);\n";
pr " CAMLlocalN (args, %d);\n"
(nr_args + if add_unit_arg then 1 else 0);
pr "\n";
pr " if (cb == NULL)\n";
pr " cb = caml_named_value (\"%s\");\n" ocaml_function;
pr "\n";
(* Construct the actual call, but note that we want to pass
* the optional arguments first in the list.
*)
let i = ref 0 in
List.iter (
fun optarg ->
let n = name_of_optargt optarg in
let uc_n = String.uppercase_ascii n in
(* optargs are all passed as [None|Some _] *)
pr " if ((optargs_bitmask & GUESTFS_%s_%s_BITMASK) == 0)\n"
uc_name uc_n;
pr " args[%d] = Val_int (0); /* None */\n" !i;
pr " else {\n";
pr " v = ";
(match optarg with
| OBool _ ->
pr "Val_bool (%s)" n;
| OInt _ -> assert false
| OInt64 _ -> assert false
| OString _ -> assert false
| OStringList _ -> assert false
);
pr ";\n";
pr " args[%d] = caml_alloc (1, 0);\n" !i;
pr " Store_field (args[%d], 0, v);\n" !i;
pr " }\n";
incr i
) optargs;
List.iter (
fun arg ->
pr " args[%d] = " !i;
(match arg with
| Bool n -> pr "Val_bool (%s)" n
| Int n -> pr "Val_int (%s)" n
| Int64 n -> pr "caml_copy_int64 (%s)" n
| String ((PlainString|Device|Pathname|Dev_or_Path), n) ->
pr "caml_copy_string (%s)" n
| String ((Mountable|Mountable_or_Path), n) ->
pr "guestfs_int_daemon_copy_mountable (%s)" n
| String _ -> assert false
| OptString _ -> assert false
| StringList _ -> assert false
| BufferIn _ -> assert false
| Pointer _ -> assert false
);
pr ";\n";
incr i
) args;
assert (!i = nr_args);
(* If there are no non-optional arguments, we add a unit arg. *)
if add_unit_arg then
pr " args[%d] = Val_unit;\n" !i;
pr " retv = caml_callbackN_exn (*cb, %d, args);\n"
(nr_args + if add_unit_arg then 1 else 0);
pr "\n";
pr " if (Is_exception_result (retv)) {\n";
pr " retv = Extract_exception (retv);\n";
pr " guestfs_int_daemon_exn_to_reply_with_error (%S, retv);\n" name;
(match errcode_of_ret ret with
| `CannotReturnError ->
pr " CAMLreturn0;\n"
| `ErrorIsMinusOne ->
pr " CAMLreturnT (int, -1);\n"
| `ErrorIsNULL ->
pr " CAMLreturnT (void *, NULL);\n"
);
pr " }\n";
pr "\n";
(match ret with
| RErr ->
pr " CAMLreturnT (int, 0);\n"
| RInt _ ->
pr " CAMLreturnT (int, Int_val (retv));\n"
| RInt64 _ ->
pr " CAMLreturnT (int, Int64_val (retv));\n"
| RBool _ ->
pr " CAMLreturnT (int, Bool_val (retv));\n"
| RConstString _ -> assert false
| RConstOptString _ -> assert false
| RString ((RPlainString|RDevice), _) ->
pr " char *ret = strdup (String_val (retv));\n";
pr " if (ret == NULL) {\n";
pr " reply_with_perror (\"strdup\");\n";
pr " CAMLreturnT (char *, NULL);\n";
pr " }\n";
pr " CAMLreturnT (char *, ret); /* caller frees */\n"
| RString (RMountable, _) ->
pr " char *ret =\n";
pr " guestfs_int_daemon_return_string_mountable (retv);\n";
pr " CAMLreturnT (char *, ret); /* caller frees */\n"
| RStringList _ ->
pr " char **ret = guestfs_int_daemon_return_string_list (retv);\n";
pr " CAMLreturnT (char **, ret); /* caller frees */\n"
| RStruct (_, typ) ->
pr " guestfs_int_%s *ret =\n" typ;
pr " return_%s (retv);\n" typ;
pr " /* caller frees */\n";
pr " CAMLreturnT (guestfs_int_%s *, ret);\n" typ
| RStructList (_, typ) ->
pr " guestfs_int_%s_list *ret =\n" typ;
pr " return_%s_list (retv);\n" typ;
pr " /* caller frees */\n";
pr " CAMLreturnT (guestfs_int_%s_list *, ret);\n" typ
| RHashtable (RPlainString, RPlainString, _) ->
pr " char **ret =\n";
pr " guestfs_int_daemon_return_hashtable_string_string (retv);\n";
pr " CAMLreturnT (char **, ret); /* caller frees */\n"
| RHashtable (RMountable, RPlainString, _) ->
pr " char **ret =\n";
pr " guestfs_int_daemon_return_hashtable_mountable_string (retv);\n";
pr " CAMLreturnT (char **, ret); /* caller frees */\n"
| RHashtable _ -> assert false
| RBufferOut _ -> assert false
);
pr "}\n";
pr "\n"
) (actions |> impl_ocaml_functions |> sort)
let generate_daemon_dispatch () =
generate_header CStyle GPLv2plus;
@@ -730,6 +1048,8 @@ let generate_daemon_optgroups_c () =
pr "#include <config.h>\n";
pr "\n";
pr "#include <caml/mlvalues.h>\n";
pr "\n";
pr "#include \"daemon.h\"\n";
pr "#include \"optgroups.h\"\n";
pr "\n";
@@ -752,7 +1072,22 @@ let generate_daemon_optgroups_c () =
pr " { \"%s\", optgroup_%s_available },\n" group group
) optgroups_names_all;
pr " { NULL, NULL }\n";
pr "};\n"
pr "};\n";
pr "\n";
pr "/* Wrappers so these functions can be called from OCaml code. */\n";
List.iter (
fun group ->
pr "extern value guestfs_int_daemon_optgroup_%s_available (value);\n"
group;
pr "\n";
pr "/* NB: This is a \"noalloc\" call. */\n";
pr "value\n";
pr "guestfs_int_daemon_optgroup_%s_available (value unitv)\n" group;
pr "{\n";
pr " return Val_bool (optgroup_%s_available ());\n" group;
pr "}\n";
pr "\n"
) optgroups_names
let generate_daemon_optgroups_h () =
generate_header CStyle GPLv2plus;
@@ -801,8 +1136,18 @@ let generate_daemon_optgroups_h () =
pr "#endif /* GUESTFSD_OPTGROUPS_H */\n"
(* Generate optgroup available functions in OCaml. *)
let generate_daemon_optgroups_ml () =
generate_header OCamlStyle GPLv2plus;
List.iter (
fun group ->
pr "external %s_available : unit -> bool =\n" group;
pr " \"guestfs_int_daemon_optgroup_%s_available\" \"noalloc\"\n" group
) optgroups_names
(* Generate structs-cleanups.c file. *)
and generate_daemon_structs_cleanups_c () =
let generate_daemon_structs_cleanups_c () =
generate_header CStyle GPLv2plus;
pr "\
@@ -852,7 +1197,7 @@ and generate_daemon_structs_cleanups_c () =
) structs
(* Generate structs-cleanups.h file. *)
and generate_daemon_structs_cleanups_h () =
let generate_daemon_structs_cleanups_h () =
generate_header CStyle GPLv2plus;
pr "\

4
generator/daemon.mli
View File

@@ -19,10 +19,14 @@
val generate_daemon_actions_h : unit -> unit
val generate_daemon_stubs_h : unit -> unit
val generate_daemon_stubs : Types.action list -> unit -> unit
val generate_daemon_caml_stubs : unit -> unit
val generate_daemon_caml_callbacks_ml : unit -> unit
val generate_daemon_caml_types_ml : unit -> unit
val generate_daemon_dispatch : unit -> unit
val generate_daemon_lvm_tokenization : unit -> unit
val generate_daemon_names : unit -> unit
val generate_daemon_optgroups_c : unit -> unit
val generate_daemon_optgroups_h : unit -> unit
val generate_daemon_optgroups_ml : unit -> unit
val generate_daemon_structs_cleanups_c : unit -> unit
val generate_daemon_structs_cleanups_h : unit -> unit

10
generator/main.ml
View File

@@ -133,6 +133,12 @@ Run it from the top source directory using the command
Daemon.generate_daemon_stubs_h;
output_to_subset "daemon/stubs-%d.c"
Daemon.generate_daemon_stubs;
output_to "daemon/caml-stubs.c"
Daemon.generate_daemon_caml_stubs;
output_to "daemon/callbacks.ml"
Daemon.generate_daemon_caml_callbacks_ml;
output_to "daemon/types.ml"
Daemon.generate_daemon_caml_types_ml;
output_to "daemon/dispatch.c"
Daemon.generate_daemon_dispatch;
output_to "daemon/names.c"
@@ -141,6 +147,8 @@ Run it from the top source directory using the command
Daemon.generate_daemon_optgroups_c;
output_to "daemon/optgroups.h"
Daemon.generate_daemon_optgroups_h;
output_to "daemon/optgroups.ml"
Daemon.generate_daemon_optgroups_ml;
output_to "daemon/lvm-tokenization.c"
Daemon.generate_daemon_lvm_tokenization;
output_to "daemon/structs-cleanups.c"
@@ -185,6 +193,8 @@ Run it from the top source directory using the command
OCaml.generate_ocaml_c;
output_to "ocaml/guestfs-c-errnos.c"
OCaml.generate_ocaml_c_errnos;
output_to "daemon/structs.ml"
OCaml.generate_ocaml_daemon_structs;
output_to "ocaml/bindtests.ml"
Bindtests.generate_ocaml_bindtests;

7
generator/types.ml
View File

@@ -379,11 +379,16 @@ type deprecated_by =
| Replaced_by of string (* replaced by another function *)
| Deprecated_no_replacement (* deprecated with no replacement *)
type impl =
| C (* implemented in C by "do_<name>" *)
| OCaml of string (* implemented in OCaml by named function *)
(* Type of an action as declared in Actions module. *)
type action = {
name : string; (* name, not including "guestfs_" *)
added : version; (* which version was the API first added *)
style : style; (* args and return value *)
impl : impl; (* implementation language (C or OCaml) *)
proc_nr : int option; (* proc number, None for non-daemon *)
tests : c_api_tests; (* C API tests *)
test_excuse : string; (* if there's no tests ... *)
@@ -439,7 +444,7 @@ type action = {
*)
let defaults = { name = "";
added = (-1,-1,-1);
style = RErr, [], []; proc_nr = None;
style = RErr, [], []; impl = C; proc_nr = None;
tests = []; test_excuse = "";
shortdesc = ""; longdesc = "";
protocol_limit_warning = false; fish_alias = [];