ocaml: Remove the old OCaml viewer program.
authorRichard W.M. Jones <rjones@redhat.com>
Mon, 8 Nov 2010 13:59:44 +0000 (13:59 +0000)
committerRichard W.M. Jones <rjones@redhat.com>
Mon, 8 Nov 2010 14:28:44 +0000 (14:28 +0000)
This program is obsolete and the code has been reused for
guestfs-browser here:
http://people.redhat.com/~rjones/guestfs-browser/

.gitignore
configure.ac
ocaml/examples/Makefile.am
ocaml/examples/README
ocaml/examples/Throbber.gif [deleted file]
ocaml/examples/Throbber.png [deleted file]
ocaml/examples/viewer.ml [deleted file]
ocaml/examples/xmllight_loader.ml [deleted file]
ocaml/examples/xmllight_loader.mli [deleted file]

index 4067aae..ad44a7a 100644 (file)
@@ -175,8 +175,6 @@ ocaml/bindtests
 ocaml/bindtests.ml
 ocaml/dllmlguestfs.so
 ocaml/examples/lvs
 ocaml/bindtests.ml
 ocaml/dllmlguestfs.so
 ocaml/examples/lvs
-ocaml/examples/throbber.ml
-ocaml/examples/viewer
 ocaml/guestfs_c_actions.c
 ocaml/guestfs_inspector.ml
 ocaml/guestfs_inspector.mli
 ocaml/guestfs_c_actions.c
 ocaml/guestfs_inspector.ml
 ocaml/guestfs_inspector.mli
index f0d6ead..979a0cd 100644 (file)
@@ -512,16 +512,6 @@ AM_CONDITIONAL([HAVE_OCAML],
                [test "x$OCAMLC" != "xno" && test "x$OCAMLFIND" != "xno"])
 AM_CONDITIONAL([HAVE_XML_LIGHT],[test "x$OCAML_PKG_xml_light" != "xno"])
 
                [test "x$OCAMLC" != "xno" && test "x$OCAMLFIND" != "xno"])
 AM_CONDITIONAL([HAVE_XML_LIGHT],[test "x$OCAML_PKG_xml_light" != "xno"])
 
-dnl Build the OCaml viewer example.  This has a lengthy list of
-dnl dependencies and we don't attempt to detect them all.  Read
-dnl the top of ocaml/examples/viewer.ml before enabling this.
-AC_ARG_ENABLE([ocaml-viewer],
-        [AS_HELP_STRING([--enable-ocaml-viewer],
-          [enable OCaml viewer (see ocaml/examples) @<:@default=no@:>@])],
-        [],
-        [enable_ocaml_viewer=no])
-AM_CONDITIONAL([BUILD_OCAML_VIEWER],[test "x$enable_ocaml_viewer" = "xyes"])
-
 dnl Check for Perl (optional, for Perl bindings).
 dnl XXX This isn't quite right, we should check for Perl devel library.
 AC_CHECK_PROG([PERL],[perl],[perl],[no])
 dnl Check for Perl (optional, for Perl bindings).
 dnl XXX This isn't quite right, we should check for Perl devel library.
 AC_CHECK_PROG([PERL],[perl],[perl],[no])
index e38a5c8..c251409 100644 (file)
@@ -1,8 +1,6 @@
 EXTRA_DIST = \
        LICENSE README \
 EXTRA_DIST = \
        LICENSE README \
-       lvs.ml \
-       viewer.ml xmllight_loader.ml xmllight_loader.mli \
-       Throbber.png Throbber.gif
+       lvs.ml
 
 CLEANFILES = throbber.ml *.cmi *.cmo *.cmx *.o lvs
 
 
 CLEANFILES = throbber.ml *.cmi *.cmo *.cmx *.o lvs
 
@@ -16,25 +14,4 @@ lvs: lvs.ml
        $(OCAMLFIND) ocamlopt $(OCAMLFINDFLAGS) \
           -warn-error A -I .. mlguestfs.cmxa $< -o $@
 
        $(OCAMLFIND) ocamlopt $(OCAMLFINDFLAGS) \
           -warn-error A -I .. mlguestfs.cmxa $< -o $@
 
-if BUILD_OCAML_VIEWER
-
-noinst_SCRIPTS += viewer
-
-viewer: throbber.ml xmllight_loader.mli xmllight_loader.ml viewer.ml
-       ocamlducefind opt $(OCAMLFINDFLAGS) \
-         -warn-error A \
-         -thread \
-         -package libvirt,lablgtk2,extlib,xml-light,ocamlduce,threads -I .. \
-         -predicates init,threads \
-         -linkpkg mlguestfs.cmxa gtkThread.cmx \
-         $^ -o $@
-
-throbber.ml: Throbber.png Throbber.gif
-       gdk_pixbuf_mlsource --build-list \
-         static Throbber.png \
-         animation Throbber.gif \
-         > $@-t && mv $@-t $@
-
-endif
-
 endif
 endif
index 663ab24..679f506 100644 (file)
@@ -4,10 +4,6 @@ Guestfs bindings to the libguestfs API.
 As they are examples, these are licensed so they can be freely copied
 and used without any restrictions.
 
 As they are examples, these are licensed so they can be freely copied
 and used without any restrictions.
 
-Note that 'viewer' needs some OCaml packages which aren't checked for
-by default by the ./configure script.  Read the comments at the top of
-the source for more details.
-
 Tips:
 
 (1) To enable verbose messages, set environment variable LIBGUESTFS_DEBUG=1
 Tips:
 
 (1) To enable verbose messages, set environment variable LIBGUESTFS_DEBUG=1
diff --git a/ocaml/examples/Throbber.gif b/ocaml/examples/Throbber.gif
deleted file mode 100644 (file)
index deac700..0000000
Binary files a/ocaml/examples/Throbber.gif and /dev/null differ
diff --git a/ocaml/examples/Throbber.png b/ocaml/examples/Throbber.png
deleted file mode 100644 (file)
index 7f23bda..0000000
Binary files a/ocaml/examples/Throbber.png and /dev/null differ
diff --git a/ocaml/examples/viewer.ml b/ocaml/examples/viewer.ml
deleted file mode 100644 (file)
index 6cd465a..0000000
+++ /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 ()
diff --git a/ocaml/examples/xmllight_loader.ml b/ocaml/examples/xmllight_loader.ml
deleted file mode 100644 (file)
index 6f0c536..0000000
+++ /dev/null
@@ -1,16 +0,0 @@
-open Xml
-open Ocamlduce.Load
-
-
-let from_xml ?ns xml =
-  let l = make ?ns () in
-  let rec aux = function
-    | Element (tag, attrs, child) ->
-        start_elem l tag attrs; List.iter aux child; end_elem l ()
-    | PCData s ->
-        text l s in
-  aux xml;
-  get l
-
-let from_file ?ns s = from_xml ?ns (parse_file s)
-let from_string ?ns s = from_xml ?ns (parse_string s)
diff --git a/ocaml/examples/xmllight_loader.mli b/ocaml/examples/xmllight_loader.mli
deleted file mode 100644 (file)
index 6c7bbe9..0000000
+++ /dev/null
@@ -1,2 +0,0 @@
-val from_file : ?ns:bool -> string -> Ocamlduce.Load.anyxml
-val from_string : ?ns:bool -> string -> Ocamlduce.Load.anyxml