mirror of
https://github.com/libguestfs/libguestfs.git
synced 2026-03-22 07:03:38 +00:00
d5b6f1df5f
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.
86 lines
2.1 KiB
OCaml
86 lines
2.1 KiB
OCaml
(* 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
|