From 277d7009668cce99d0534d780c3984675bf20cd0 Mon Sep 17 00:00:00 2001 From: Richard Jones Date: Tue, 22 Jun 2010 14:32:45 -0400 Subject: [PATCH] Disk usage dialog. --- Makefile.am | 3 ++- filetree.ml | 75 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++----- slave.ml | 43 +++++++++++++++++++++++++++++++++-- slave.mli | 28 +++++++++++++++++++++++ window.ml | 9 ++++++-- 5 files changed, 147 insertions(+), 11 deletions(-) diff --git a/Makefile.am b/Makefile.am index 569d350..967dfac 100644 --- 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 --- 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 --- 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 --- 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 --- 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. -- 1.8.3.1