Disk usage dialog.

diff --git a/Makefile.am b/Makefile.am
index 569d350..967dfac 100644 (file)
--- a/Makefile.am
+++ b/Makefile.am
@@ -52,7 +52,8 @@ OCAMLCFLAGS = \
        -g \
        -warn-error A \
        -thread \
-       -package libvirt,guestfs,lablgtk2,extlib,xml-light,threads
+       -package libvirt,guestfs,lablgtk2,extlib,xml-light,threads \
+       -predicates threads
 
 OCAMLOPTFLAGS = $(OCAMLCFLAGS)
 

diff --git a/filetree.ml b/filetree.ml
index 1969cc7..3af820d 100644 (file)
--- a/filetree.ml
+++ b/filetree.ml
@@ -390,8 +390,8 @@ and button_press tree ev =
 and make_context_menu tree ~dir ~file paths =
   let _, _, _, _, rw, _ = tree in
   let n = List.length paths in
-
-  debug "make_context_menu dir %b file %b n %d" dir file n;
+  assert (n > 0);                      (* calling code ensures this *)
+  let path0 = List.hd paths in
 
   let menu = GMenu.menu () in
   let factory = new GMenu.factory menu in
@@ -404,10 +404,15 @@ and make_context_menu tree ~dir ~file paths =
   ignore (factory#add_separator ());
 
   if dir && n = 1 then (
-    ignore (factory#add_item "Disk usage ...");
-    ignore (factory#add_item "Export as an archive (tar etc) ...");
-    ignore (factory#add_item "Export checksums ...");
-    ignore (factory#add_item "Export as a list of files ...");
+    let item = factory#add_item "Disk _usage ..." in
+    ignore (item#connect#activate ~callback:(disk_usage_dialog tree path0));
+    let item = factory#add_item "_Export as an archive (tar etc) ..." in
+    ignore (item#connect#activate ~callback:(export_archive_dialog tree path0));
+    let item = factory#add_item "Export _checksums ..." in
+    ignore (item#connect#activate
+              ~callback:(export_checksums_dialog tree path0));
+    let item = factory#add_item "Export as a _list of files ..." in
+    ignore (item#connect#activate ~callback:(export_list_dialog tree path0));
   );
 
   if file then
@@ -440,3 +445,61 @@ and make_context_menu tree ~dir ~file paths =
   );
 
   menu
+
+(* The disk usage dialog. *)
+and disk_usage_dialog tree path0 () =
+  let model, _, _, dev, _,_ = tree in
+  let row = model#get_iter (fst path0) in
+  let dir = get_pathname tree row in
+
+  (* We can't use GWindow.message_dialog since lablgtk2 doesn't expose
+   * the label field.  It wouldn't help very much anyway.
+   *)
+  let title = "Calculating disk usage ..." in
+  let dlg = GWindow.dialog ~title ~modal:true () in
+  let text =
+    sprintf "Calculating disk usage of %s ...  This may take a moment." dir in
+  let label = GMisc.label ~text ~packing:dlg#vbox#pack () in
+  dlg#add_button "Stop" `STOP;
+  dlg#add_button "Close" `DELETE_EVENT;
+  let close_button, stop_button =
+    match dlg#action_area#children with
+    | c::s::_ -> c, s
+    | _ -> assert false in
+  close_button#misc#set_sensitive false;
+
+  let callback = function
+    | `STOP -> debug "STOP response" (* XXX NOT IMPL XXX *)
+    | `DELETE_EVENT -> debug "DELETE_EVENT response"; dlg#destroy ()
+  in
+  ignore (dlg#connect#response ~callback);
+
+  Slave.disk_usage dev dir (
+    fun kbytes -> (* Called when operation has finished. *)
+      dlg#set_title "Disk usage";
+      label#set_text (sprintf "Disk usage of %s: %Ld KB" dir kbytes);
+      close_button#misc#set_sensitive true;
+      stop_button#misc#set_sensitive false
+  );
+
+  (* NB. We cannot use dlg#run.  See:
+   * http://www.math.nagoya-u.ac.jp/~garrigue/soft/olabl/lablgtk-list/600.txt
+   * Therefore this function just exits back to the ordinary main loop.
+   *)
+  dlg#show ()
+
+and export_archive_dialog tree path0 () =
+  (* XXX NOT IMPL XXX *)
+  ()
+
+and export_checksums_dialog tree path0 () =
+  (* XXX NOT IMPL XXX *)
+  ()
+
+and export_list_dialog tree path0 () =
+  (* XXX NOT IMPL XXX *)
+  ()
+
+and do_export_dialog tree path0 t =
+  (* XXX NOT IMPL XXX *)
+  ()

diff --git a/slave.ml b/slave.ml
index d1cff80..ba45cfb 100644 (file)
--- a/slave.ml
+++ b/slave.ml
@@ -38,6 +38,8 @@ type command =
   | Open_images of string list * rw_flag callback
   | Get_volumes of volume callback
   | Read_directory of string * string * direntry list callback
+  | Disk_usage of string * string * int64 callback
+  | Export_dir_to of export_t * string * string * string * unit callback
 
 and domain = {
   dom_id : int;
@@ -61,7 +63,13 @@ and direntry = {
   dent_link : string;
 }
 
-let string_of_command = function
+and export_t =
+  | Export_tar
+  | Export_tgz
+  | Export_checksums of string
+  | Export_list
+
+let rec string_of_command = function
   | Exit_thread -> "Exit_thread"
   | Connect (Some name, _) -> sprintf "Connect %s" name
   | Connect (None, _) -> "Connect NULL"
@@ -71,8 +79,17 @@ let string_of_command = function
       sprintf "Open_images [%s]" (String.concat "; " images)
   | Get_volumes _ -> "Get_volumes"
   | Read_directory (dev, dir, _) -> sprintf "Read_directory %s %s" dev dir
+  | Disk_usage (dev, dir, _) -> sprintf "Disk_usage %s %s" dev dir
+  | Export_dir_to (t, dev, dir, file, _) ->
+      sprintf "Export_dir_to %s %s %s %s" (string_of_export_t t) dev dir file
+
+and string_of_export_t = function
+  | Export_tar -> "Export_tar"
+  | Export_tgz -> "Export_tgz"
+  | Export_checksums alg -> sprintf "Export_checksums %s" alg
+  | Export_list -> "Export_list"
 
-let string_of_rw_flag = function RO -> "RO" | RW -> "RW"
+and string_of_rw_flag = function RO -> "RO" | RW -> "RW"
 
 let no_callback _ = ()
 
@@ -118,6 +135,9 @@ let get_volumes cb = send_to_slave (Get_volumes cb)
 let open_domain name cb = send_to_slave (Open_domain (name, cb))
 let open_images images cb = send_to_slave (Open_images (images, cb))
 let read_directory dev dir cb = send_to_slave (Read_directory (dev, dir, cb))
+let disk_usage dev dir cb = send_to_slave (Disk_usage (dev, dir, cb))
+let export_dir_to t dev dir file cb =
+  send_to_slave (Export_dir_to (t, dev, dir, file, cb))
 
 (*----- Slave thread starts here -----*)
 
@@ -141,6 +161,8 @@ let with_mount_ro g dev (f : unit -> 'a) : 'a =
   ) ()
 
 let rec loop () =
+  debug "thread id %d: top of slave loop ..." (Thread.id (Thread.self ()));
+
   (* Get the next command. *)
   let cmd =
     with_lock q_lock (
@@ -247,6 +269,23 @@ and execute_command = function
       ) entries in
       GtkThread.async cb entries
 
+  | Disk_usage (dev, dir, cb) ->
+      let g = get_g () in
+      let kb = with_mount_ro g dev (fun () -> G.du g dir) in
+      GtkThread.async cb kb
+
+  | Export_dir_to (t, dev, dir, file, cb) ->
+      let g = get_g () in
+      with_mount_ro g dev (
+        fun () ->
+          (match t with
+           | Export_tar -> G.tar_out g
+           | Export_tgz -> G.tgz_out g
+           | Export_checksums alg -> G.checksums_out g alg
+           | Export_list -> G.find0 g) dir file
+      );
+      GtkThread.async cb ()
+
 (* Expect to be connected, and return the current libvirt connection. *)
 and get_conn () =
   match !conn with

diff --git a/slave.mli b/slave.mli
index f60f835..1e310bc 100644 (file)
--- a/slave.mli
+++ b/slave.mli
@@ -131,6 +131,34 @@ val read_directory : string -> string -> direntry list callback -> unit
       Note that [.] and [..] entries are not included in the result,
       and the list is sorted on the [filename] field. *)
 
+val disk_usage : string -> string -> int64 callback -> unit
+  (** [disk_usage dev dir cb] sends the [Disk_usage] message to the
+      slave thread.
+
+      This causes the slave thread to estimate the disk usage of the
+      directory (or file) [dir] from volume [dev], and call [cb] with
+      the result (size in {b kilobytes}). *)
+
+type export_t =
+  | Export_tar                      (** uncompressed tar archive *)
+  | Export_tgz                      (** gzip compressed tar archive *)
+  | Export_checksums of string      (** checksums using algorithm *)
+  | Export_list                     (** list of file names, \0-separated *)
+      (** Export format used by {!export_dir_to}. *)
+
+val export_dir_to : export_t -> string -> string -> string -> unit callback -> unit
+  (** [export_dir_to t dev dir file cb] sends the [Export_dir_to] message
+      to the slave thread.
+
+      This causes the slave thread to export the directory [dir] on
+      device [dev] to the host file called [file].  The precise
+      operation (ie. what is exported) is controlled by the type
+      [export_t].  When the export has been completed, the callback
+      [cb] is called in the main thread.
+
+      Libguestfs doesn't offer any way to view progress of this
+      operation, which could potentially take a long time. *)
+
 val discard_command_queue : unit -> unit
   (** [discard_command_queue ()] discards any commands on the command
       queue.  The currently running command is not (and can not be)

diff --git a/window.ml b/window.ml
index 10cae04..f5ec47d 100644 (file)
--- a/window.ml
+++ b/window.ml
@@ -146,6 +146,7 @@ let rec open_main_window () =
               let name = model#get ~row ~column in
               ds.set_statusbar (sprintf "Opening %s ..." name);
               ds.clear_notebook ();
+              Slave.discard_command_queue ();
               Slave.open_domain name (opened_domain ds))
   );
 
@@ -314,13 +315,17 @@ and got_volume ds rw vol =
 and connect_dialog ds () =
   debug "connect menu";
   (*ds.clear_notebook ();*)
-  failwith "XXX CONNECT DLG NOT IMPL"
+  (*Slave.discard_command_queue ();*)
+  (* XXX NOT IMPL XXX *)
+  ()
 
 (* Open the disk images dialog. *)
 and open_dialog ds () =
   debug "open menu";
   (*ds.clear_notebook ();*)
-  failwith "XXX OPEN DLG NOT IMPL"
+  (*Slave.discard_command_queue ();*)
+  (* XXX NOT IMPL XXX *)
+  ()
 
 (* The introductory text which appears in the tabbed notebook to
  * tell the user how to start.  XXX We should add images.