ocaml: Remove the old OCaml viewer program.

This program is obsolete and the code has been reused for
guestfs-browser here:
http://people.redhat.com/~rjones/guestfs-browser/

1 files changed, 0 insertions, 706 deletions

diff --git a/ocaml/examples/viewer.ml b/ocaml/examples/viewer.ml
deleted file mode 100644
index 6cd465ab..00000000
--- a/ocaml/examples/viewer.ml
+++ /dev/null
@@ -1,706 +0,0 @@
-(* This is a virtual machine graphical viewer tool.
- * Written by Richard W.M. Jones, Sept. 2009.
- *
- * It demonstrates some complex programming techniques: OCaml, Gtk+,
- * threads, and use of both libguestfs and libvirt from threads.
- *
- * You will need the following installed in order to compile it:
- *   - ocaml (http://caml.inria.fr/)
- *   - ocamlfind (http://projects.camlcity.org/projects/findlib.html/)
- *   - extlib (http://code.google.com/p/ocaml-extlib/)
- *   - lablgtk2 (http://wwwfun.kurims.kyoto-u.ac.jp/soft/lsl/lablgtk.html
- *   - xml-light (http://tech.motion-twin.com/xmllight.html)
- *   - cduce and ocamlduce (http://cduce.org/)
- *   - ocaml-libvirt (http://libvirt.org/ocaml)
- *   - ocaml-libguestfs
- *
- * Note that most/all of these are available as packages via Fedora,
- * Debian, Ubuntu or GODI.  You won't need to compile them from source.
- *
- * You will also need to configure libguestfs:
- *   ./configure --enable-ocaml-viewer
- *
- * All programs in the ocaml/examples subdirectory, including this
- * one, may be freely copied without any restrictions.
- *)
-
-(* Architecturally, there is one main thread which does all the Gtk
- * calls, and one slave thread which executes all libguestfs and
- * libvirt calls.  The main thread sends commands to the slave thread,
- * which are delivered in a queue and acted on in sequence.  Responses
- * are delivered back to the main thread as commands finish.
- *
- * The commands are just OCaml objects (type: Slave.command).  The
- * queue of commands is an OCaml Queue.  The responses are sent by adding
- * idle events to the glib main loop[1].
- *
- * If a command fails, it causes the input queue to be cleared.  In
- * this case, a failure response is sent to the main loop which
- * causes the display to be reset and possibly an error message to
- * be shown.
- *
- * The global variables [conn], [dom] and [g] are the libvirt
- * connection, current domain, and libguestfs handle respectively.
- * Because these can be accessed by both threads, they are
- * protected from the main thread by access methods which
- * (a) prevent the main thread from using them unlocked, and
- * (b) prevent the main thread from doing arbitrary / long-running
- * operations on them (the main thread must send a command instead).
- *
- * [1] http://library.gnome.org/devel/gtk-faq/stable/x499.html
- *)
-
-open Printf
-open ExtList
-
-let (//) = Filename.concat
-
-(* Short names for commonly used modules. *)
-module C = Libvirt.Connect
-module Cd = Condition
-module D = Libvirt.Domain
-module G = Guestfs
-module M = Mutex
-module Q = Queue
-
-let verbose = ref false                       (* Verbose mode. *)
-
-let debug fs =
-  let f str = if !verbose then ( prerr_string str; prerr_newline () ) in
-  ksprintf f fs
-
-(*----------------------------------------------------------------------*)
-(* Slave thread.  The signature describes what operations the main
- * thread can perform, and protects the locked internals of the
- * slave thread.
- *)
-module Slave : sig
-  type 'a callback = 'a -> unit
-
-  type partinfo = {
-    pt_name : string;                (** device / LV name *)
-    pt_size : int64;                (** in bytes *)
-    pt_content : string;        (** the output of the 'file' command *)
-    pt_statvfs : G.statvfs option; (** None if not mountable *)
-  }
-
-  val no_callback : 'a callback
-    (** Use this as the callback if you don't want a callback. *)
-
-  val set_failure_callback : exn callback -> unit
-    (** Set the function that is called in the main thread whenever
-        there is a command failure in the slave.  The command queue
-        is cleared before this is sent.  [exn] is the exception
-        associated with the failure. *)
-
-  val set_busy_callback : [`Busy|`Idle] callback -> unit
-    (** Set the function that is called in the main thread whenever
-        the slave thread goes busy or idle. *)
-
-  val exit_thread : unit -> unit
-    (** [exit_thread ()] causes the slave thread to exit. *)
-
-  val connect : string option -> string option callback -> unit
-    (** [connect uri cb] connects to libvirt [uri], and calls [cb]
-        if it completes successfully.  Any previous connection is
-        automatically cleaned up and disconnected. *)
-
-  val get_domains : string list callback -> unit
-    (** [get_domains cb] gets the list of active domains from libvirt,
-        and calls [cb domains] with the names of those domains. *)
-
-  val open_domain : string -> partinfo list callback -> unit
-    (** [open_domain dom cb] sets the domain [dom] as the current
-        domain, and launches a libguestfs handle for it.  Any previously
-        current domain and libguestfs handle is closed.  Once the
-        libguestfs handle is opened (which usually takes some time),
-        callback [cb] is called with the list of partitions found
-        in the guest. *)
-
-  val slave_loop : unit -> unit
-    (** The slave thread's main loop, running in the slave thread. *)
-
-end = struct
-  type partinfo = {
-    pt_name : string;
-    pt_size : int64;
-    pt_content : string;
-    pt_statvfs : G.statvfs option;
-  }
-
-  (* Commands sent by the main thread to the slave thread.  When
-   * [cmd] is successfully completed, [callback] will be delivered
-   * (in the main thread).  If [cmd] fails, then the global error
-   * callback will be delivered in the main thread.
-   *)
-  type command =
-    | Exit_thread
-    | Connect of string option * string option callback
-    | Get_domains of string list callback
-    | Open_domain of string * partinfo list callback
-  and 'a callback = 'a -> unit
-
-  let string_of_command = function
-    | Exit_thread -> "Exit_thread"
-    | Connect (None, _) -> "Connect [no uri]"
-    | Connect (Some uri, _) -> "Connect " ^ uri
-    | Get_domains _ -> "Get_domains"
-    | Open_domain (name, _) -> "Open_domain " ^ name
-
-  let no_callback _ = ()
-
-  let failure_cb = ref (fun _ -> ())
-  let set_failure_callback cb = failure_cb := cb
-
-  let busy_cb = ref (fun _ -> ())
-  let set_busy_callback cb = busy_cb := cb
-
-  (* Execute a function, while holding a mutex.  If the function
-   * fails, ensure we release the mutex before rethrowing the
-   * exception.
-   *)
-  type ('a, 'b) choice = Either of 'a | Or of 'b
-  let with_lock m f =
-    M.lock m;
-    let r = try Either (f ()) with exn -> Or exn in
-    M.unlock m;
-    match r with
-    | Either r -> r
-    | Or exn -> raise exn
-
-  let q = Q.create ()                        (* queue of commands *)
-  let q_lock = M.create ()
-  let q_cond = Cd.create ()
-
-  (* Send a command message to the slave thread. *)
-  let send_to_slave c =
-    debug "sending to slave: %s" (string_of_command c);
-    with_lock q_lock (
-      fun () ->
-        Q.push c q;
-        Cd.signal q_cond
-    )
-
-  let exit_thread () =
-    with_lock q_lock (fun () -> Q.clear q);
-    send_to_slave Exit_thread
-
-  let connect uri cb =
-    send_to_slave (Connect (uri, cb))
-
-  let get_domains cb =
-    send_to_slave (Get_domains cb)
-
-  let open_domain dom cb =
-    send_to_slave (Open_domain (dom, cb))
-
-  (* These are not protected by a mutex because we don't allow
-   * any references to these objects to escape from the slave
-   * thread.
-   *)
-  let conn = ref None                        (* libvirt connection *)
-  let dom = ref None                        (* libvirt domain *)
-  let g = ref None                        (* libguestfs handle *)
-
-  let quit = ref false
-
-  let rec slave_loop () =
-    debug "Slave.slave_loop: waiting for a command";
-    let c =
-      with_lock q_lock (
-        fun () ->
-          while Q.is_empty q do
-            Cd.wait q_cond q_lock
-          done;
-          Q.pop q
-      ) in
-
-    (try
-       debug "Slave.slave_loop: executing: %s" (string_of_command c);
-       !busy_cb `Busy;
-       exec_command c;
-       !busy_cb `Idle;
-       debug "Slave.slave_loop: command succeeded";
-     with exn ->
-       (* If an exception is thrown, it means the command failed.  In
-        * this case we clear the command queue and deliver the failure
-        * callback in the main thread.
-        *)
-       debug "Slave.slave_loop: command failed";
-
-       !busy_cb `Idle;
-       with_lock q_lock (fun () -> Q.clear q);
-       GtkThread.async !failure_cb exn
-    );
-
-    if !quit then Thread.exit ();
-    slave_loop ()
-
-  and exec_command = function
-    | Exit_thread ->
-        quit := true; (* quit first in case disconnect_all throws an exn *)
-        disconnect_all ()
-
-    | Connect (name, cb) ->
-        disconnect_all ();
-        conn := Some (C.connect_readonly ?name ());
-        cb name
-
-    | Get_domains cb ->
-        let conn = Option.get !conn in
-        let doms = D.get_domains conn [D.ListAll] in
-        (* Only return the names, so that the libvirt objects
-         * aren't leaked outside the slave thread.
-         *)
-        let doms = List.map D.get_name doms in
-        cb doms
-
-    | Open_domain (domname, cb) ->
-        let conn = Option.get !conn in
-        disconnect_dom ();
-        dom := Some (D.lookup_by_name conn domname);
-        let dom = Option.get !dom in
-
-        (* Get the devices. *)
-        let xml = D.get_xml_desc dom in
-        let devs = get_devices_from_xml xml in
-
-        (* Create the libguestfs handle and launch it. *)
-        let g' = G.create () in
-        List.iter (G.add_drive_ro g') devs;
-        G.launch g';
-        g := Some g';
-
-        (* Get the list of partitions. *)
-        let parts = Array.to_list (G.list_partitions g') in
-        (* Remove any which are PVs. *)
-        let pvs = Array.to_list (G.pvs g') in
-        let parts = List.filter (fun part -> not (List.mem part pvs)) parts in
-        let lvs = Array.to_list (G.lvs g') in
-        let parts = parts @ lvs in
-
-        let parts = List.map (
-          fun part ->
-            (* Find out the size of each partition. *)
-            let size = G.blockdev_getsize64 g' part in
-
-            (* Find out what's on each partition. *)
-            let content = G.file g' part in
-
-            (* Try to mount it. *)
-            let statvfs =
-              try
-                G.mount_ro g' part "/";
-                Some (G.statvfs g' "/")
-              with _ -> None in
-            G.umount_all g';
-
-            { pt_name = part; pt_size = size; pt_content = content;
-              pt_statvfs = statvfs }
-        ) parts in
-
-        (* Call the callback. *)
-        cb parts
-
-  (* Close all libvirt/libguestfs handles. *)
-  and disconnect_all () =
-    disconnect_dom ();
-    (match !conn with Some conn -> C.close conn | None -> ());
-    conn := None
-
-  (* Close dom and libguestfs handles. *)
-  and disconnect_dom () =
-    (match !g with Some g -> G.close g | None -> ());
-    g := None;
-    (match !dom with Some dom -> D.free dom | None -> ());
-    dom := None
-
-  and get_devices_from_xml xml =
-    (* Lengthy discussion of the merits or otherwise of this code here:
-     * http://groups.google.com/group/fa.caml/browse_thread/thread/48e05d49b0f21b8a/5296bceb31ebfff3
-     *)
-    let xml = Xmllight_loader.from_string xml in
-    let xs = {{ [xml] }} in
-    let xs = {{ (((xs.(<domain..>_)) / .(<devices..>_)) / .(<disk..>_)) / }} in
-    let xs = {{ map xs with
-                | <source dev=(Latin1 & s) ..>_
-                | <source file=(Latin1 & s) ..>_ -> [s]
-                | _ -> [] }} in
-    {: xs :}
-end
-(* End of slave thread code. *)
-(*----------------------------------------------------------------------*)
-
-(* Display state. *)
-type display_state = {
-  window : GWindow.window;
-  vmlist_set : string list -> unit;
-  throbber_set : [`Busy|`Idle] -> unit;
-  da : GMisc.drawing_area;
-  draw : GDraw.drawable;
-  drawing_area_repaint : unit -> unit;
-  set_statusbar : string -> unit;
-  clear_statusbar : unit -> unit;
-  pango_large_context : GPango.context_rw;
-  pango_small_context : GPango.context_rw;
-}
-
-(* This is called in the main thread whenever a command fails in the
- * slave thread.  The command queue has been cleared before this is
- * called, so our job here is to reset the main window, and if
- * necessary to turn the exception into an error message.
- *)
-let failure ds exn =
-  let title = "Error" in
-  let msg = Printexc.to_string exn in
-  debug "failure callback: %s" msg;
-  let icon = GMisc.image () in
-  icon#set_stock `DIALOG_ERROR;
-  icon#set_icon_size `DIALOG;
-  GToolbox.message_box ~title ~icon msg
-
-(* This is called in the main thread when the slave thread transitions
- * to busy or idle.
- *)
-let busy ds state = ds.throbber_set state
-
-(* Main window and callbacks from menu etc. *)
-let main_window opened_domain repaint =
-  let window_title = "Virtual machine graphical viewer" in
-  let window = GWindow.window ~width:800 ~height:600 ~title:window_title () in
-  let vbox = GPack.vbox ~packing:window#add () in
-
-  (* Do the menus. *)
-  let menubar = GMenu.menu_bar ~packing:vbox#pack () in
-  let factory = new GMenu.factory menubar in
-  let accel_group = factory#accel_group in
-  let connect_menu = factory#add_submenu "_Connect" in
-
-  let factory = new GMenu.factory connect_menu ~accel_group in
-  let quit_item = factory#add_item "E_xit" ~key:GdkKeysyms._Q in
-
-  (* Quit. *)
-  let quit _ = GMain.quit (); false in
-  ignore (window#connect#destroy ~callback:GMain.quit);
-  ignore (window#event#connect#delete ~callback:quit);
-  ignore (quit_item#connect#activate
-            ~callback:(fun () -> ignore (quit ()); ()));
-
-  (* Top status area. *)
-  let hbox = GPack.hbox ~border_width:4 ~packing:vbox#pack () in
-  ignore (GMisc.label ~text:"Guest: " ~packing:hbox#pack ());
-
-  (* List of VMs. *)
-  let vmcombo = GEdit.combo_box_text ~packing:hbox#pack () in
-  let vmlist_set names =
-    let combo, (model, column) = vmcombo in
-    model#clear ();
-    List.iter (
-      fun name ->
-        let row = model#append () in
-        model#set ~row ~column name
-    ) names
-  in
-
-  (* Throbber, http://faq.pygtk.org/index.py?req=show&file=faq23.037.htp *)
-  let static = Throbber.static () in
-  (*let animation = Throbber.animation () in*)
-  let throbber =
-    GMisc.image ~pixbuf:static ~packing:(hbox#pack ~from:`END) () in
-  let throbber_set = function
-    | `Busy -> (*throbber#set_pixbuf animation*)
-        (* Workaround because no binding for GdkPixbufAnimation: *)
-        let file = Filename.dirname Sys.argv.(0) // "Throbber.gif" in
-        throbber#set_file file
-    | `Idle -> throbber#set_pixbuf static
-  in
-
-  (* Drawing area. *)
-  let da = GMisc.drawing_area ~packing:(vbox#pack ~expand:true ~fill:true) () in
-  da#misc#realize ();
-  let draw = new GDraw.drawable da#misc#window in
-  window#set_geometry_hints ~min_size:(80,80) (da :> GObj.widget);
-
-  (* Calling this can be used to force a redraw of the drawing area. *)
-  let drawing_area_repaint () = GtkBase.Widget.queue_draw da#as_widget in
-
-  (* Pango contexts used to draw large and small text. *)
-  let pango_large_context = da#misc#create_pango_context in
-  pango_large_context#set_font_description (Pango.Font.from_string "Sans 12");
-  let pango_small_context = da#misc#create_pango_context in
-  pango_small_context#set_font_description (Pango.Font.from_string "Sans 8");
-
-  (* Status bar at the bottom of the screen. *)
-  let set_statusbar =
-    let statusbar = GMisc.statusbar ~packing:vbox#pack () in
-    let context = statusbar#new_context ~name:"Standard" in
-    ignore (context#push window_title);
-    fun msg ->
-      context#pop ();
-      ignore (context#push msg)
-  in
-  let clear_statusbar () = set_statusbar "" in
-
-  (* Display the window and enter Gtk+ main loop. *)
-  window#show ();
-  window#add_accel_group accel_group;
-
-  (* display_state which is threaded through all the other callbacks,
-   * allowing callbacks to update the window.
-   *)
-  let ds =
-    { window = window; vmlist_set = vmlist_set; throbber_set = throbber_set;
-      da = da; draw = draw; drawing_area_repaint = drawing_area_repaint;
-      set_statusbar = set_statusbar; clear_statusbar = clear_statusbar;
-      pango_large_context = pango_large_context;
-      pango_small_context = pango_small_context; } in
-
-  (* Set up some callbacks which require access to the display_state. *)
-  ignore (
-    let combo, (model, column) = vmcombo in
-    combo#connect#changed
-      ~callback:(
-        fun () ->
-          match combo#active_iter with
-          | None -> ()
-          | Some row ->
-              let name = model#get ~row ~column in
-              ds.set_statusbar (sprintf "Opening %s ..." name);
-              Slave.open_domain name (opened_domain ds))
-  );
-
-  ignore (da#event#connect#expose ~callback:(repaint ds));
-
-  ds
-
-(* Partition info for the current domain, if one is loaded. *)
-let parts = ref None
-
-(* This is called in the main thread when we've connected to libvirt. *)
-let rec connected ds uri =
-  debug "connected callback";
-  let msg =
-    match uri with
-    | None -> "Connected to libvirt"
-    | Some uri -> sprintf "Connected to %s" uri in
-  ds.set_statusbar msg;
-  Slave.get_domains (got_domains ds)
-
-(* This is called in the main thread when we've got the list of domains. *)
-and got_domains ds doms =
-  debug "got_domains callback: (%s)" (String.concat " " doms);
-  ds.vmlist_set doms
-
-(* This is called when we have opened a domain. *)
-and opened_domain ds parts' =
-  debug "opened_domain callback";
-  ds.clear_statusbar ();
-  parts := Some parts';
-  ds.drawing_area_repaint ()
-
-and repaint ds _ =
-  (match !parts with
-   | None -> ()
-   | Some parts ->
-       real_repaint ds parts
-  );
-  false
-
-and real_repaint ds parts =
-  let width, height = ds.draw#size in
-  ds.draw#set_background `WHITE;
-  ds.draw#set_foreground `WHITE;
-  ds.draw#rectangle ~x:0 ~y:0 ~width ~height ~filled:true ();
-
-  let sum = List.fold_left Int64.add 0L in
-  let totsize = sum (List.map (fun { Slave.pt_size = size } -> size) parts) in
-
-  let scale = (float height -. 16.) /. Int64.to_float totsize in
-
-  (* Calculate the height in pixels of each partition, if we were to
-   * display it at a true relative size.
-   *)
-  let parts =
-    List.map (
-      fun ({ Slave.pt_size = size } as part) ->
-        let h = scale *. Int64.to_float size in
-        (h, part)
-    ) parts in
-
-  (*
-  if !verbose then (
-    eprintf "real_repaint: before borrowing:\n";
-    List.iter (
-      fun (h, part) ->
-        eprintf "%s\t%g pix\n" part.Slave.pt_name h
-    ) parts
-  );
-  *)
-
-  (* Now adjust the heights of small partitions so they "borrow" some
-   * height from the larger partitions.
-   *)
-  let min_h = 32. in
-  let rec borrow needed = function
-    | [] -> 0., []
-    | (h, part) :: parts ->
-        let spare = h -. min_h in
-        if spare >= needed then (
-          needed, (h -. needed, part) :: parts
-        ) else if spare > 0. then (
-          let needed = needed -. spare in
-          let spare', parts = borrow needed parts in
-          spare +. spare', (h -. spare, part) :: parts
-        ) else (
-          let spare', parts = borrow needed parts in
-          spare', (h, part) :: parts
-        )
-  in
-  let rec loop = function
-    | parts, [] -> List.rev parts
-    | prev, ((h, part) :: parts) ->
-        let needed = min_h -. h in
-        let h, prev, parts =
-          if needed > 0. then (
-            (* Find some spare height in a succeeding partition(s). *)
-            let spare, parts = borrow needed parts in
-            (* Or if not, in a preceeding partition(s). *)
-            let spare, prev =
-              if spare = 0. then borrow needed prev else spare, prev in
-            h +. spare, prev, parts
-          ) else (
-            h, prev, parts
-          ) in
-        loop (((h, part) :: prev), parts)
-  in
-  let parts = loop ([], parts) in
-
-  (*
-  if !verbose then (
-    eprintf "real_repaint: after borrowing:\n";
-    List.iter (
-      fun (h, part) ->
-        eprintf "%s\t%g pix\n" part.Slave.pt_name h
-    ) parts
-  );
-  *)
-
-  (* Calculate the proportion space used in each partition. *)
-  let parts = List.map (
-    fun (h, part) ->
-      let used =
-        match part.Slave.pt_statvfs with
-        | None -> 0.
-        | Some { G.bavail = bavail; blocks = blocks } ->
-            let num = Int64.to_float (Int64.sub blocks bavail) in
-            let denom = Int64.to_float blocks in
-            num /. denom in
-      (h, used, part)
-  ) parts in
-
-  (* Draw it. *)
-  ignore (
-    List.fold_left (
-      fun y (h, used, part) ->
-        (* This partition occupies pixels 8+y .. 8+y+h-1 *)
-        let yb = 8 + int_of_float y
-        and yt = 8 + int_of_float (y +. h) in
-
-        ds.draw#set_foreground `WHITE;
-        ds.draw#rectangle ~x:8 ~y:yb ~width:(width-16) ~height:(yt-yb)
-          ~filled:true ();
-
-        let col =
-          if used < 0.6 then `NAME "grey"
-          else if used < 0.8 then `NAME "pink"
-          else if used < 0.9 then `NAME "hot pink"
-          else `NAME "red" in
-        ds.draw#set_foreground col;
-        let w = int_of_float (used *. (float width -. 16.)) in
-        ds.draw#rectangle ~x:8 ~y:yb ~width:w ~height:(yt-yb) ~filled:true ();
-
-        ds.draw#set_foreground `BLACK;
-        ds.draw#rectangle ~x:8 ~y:yb ~width:(width-16) ~height:(yt-yb) ();
-
-        (* Large text - the device name. *)
-        let txt = ds.pango_large_context#create_layout in
-        Pango.Layout.set_text txt part.Slave.pt_name;
-        let fore = `NAME "dark slate grey" in
-        ds.draw#put_layout ~x:12 ~y:(yb+4) ~fore txt;
-
-        let { Pango.height = txtheight; Pango.width = txtwidth } =
-          Pango.Layout.get_pixel_extent txt in
-
-        (* Small text below - the content. *)
-        let txt = ds.pango_small_context#create_layout in
-        Pango.Layout.set_text txt part.Slave.pt_content;
-        let fore = `BLACK in
-        ds.draw#put_layout ~x:12 ~y:(yb+4+txtheight) ~fore txt;
-
-        (* Small text right - size. *)
-        let size =
-          match part.Slave.pt_statvfs with
-          | None -> printable_size part.Slave.pt_size
-          | Some { G.blocks = blocks; bsize = bsize } ->
-              let bytes = Int64.mul blocks bsize in
-              let pc = 100. *. used in
-              sprintf "%s (%.1f%% used)" (printable_size bytes) pc in
-        let txt = ds.pango_small_context#create_layout in
-        Pango.Layout.set_text txt size;
-        ds.draw#put_layout ~x:(16+txtwidth) ~y:(yb+4) ~fore txt;
-
-        (y +. h)
-    ) 0. parts
-  )
-
-and printable_size bytes =
-  if bytes < 16_384L then sprintf "%Ld bytes" bytes
-  else if bytes < 16_777_216L then
-    sprintf "%Ld KiB" (Int64.div bytes 1024L)
-  else if bytes < 17_179_869_184L then
-    sprintf "%Ld MiB" (Int64.div bytes 1_048_576L)
-  else
-    sprintf "%Ld GiB" (Int64.div bytes 1_073_741_824L)
-
-let default_uri = ref ""
-
-let argspec = Arg.align [
-  "-verbose", Arg.Set verbose, "Verbose mode";
-  "-connect", Arg.Set_string default_uri, "Connect to libvirt URI";
-]
-
-let anon_fun _ =
-  failwith (sprintf "%s: unknown command line argument"
-              (Filename.basename Sys.executable_name))
-
-let usage_msg =
-  sprintf "\
-
-%s: graphical virtual machine disk usage viewer
-
-Options:"
-    (Filename.basename Sys.executable_name)
-
-let main () =
-  Arg.parse argspec anon_fun usage_msg;
-
-  (* Start up the slave thread. *)
-  let slave = Thread.create Slave.slave_loop () in
-
-  (* Set up the display. *)
-  let ds = main_window opened_domain repaint in
-
-  Slave.set_failure_callback (failure ds);
-  Slave.set_busy_callback (busy ds);
-  let uri = match !default_uri with "" -> None | s -> Some s in
-  Slave.connect uri (connected ds);
-
-  (* Run the main thread. When this returns, the application has been closed. *)
-  GtkThread.main ();
-
-  (* Tell the slave thread to exit and wait for it to do so. *)
-  Slave.exit_thread ();
-  Thread.join slave
-
-let () =
-  main ()