From a239ebb3028d4860cbf4d3e09dc676104448aabc Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Mon, 8 Nov 2010 13:59:44 +0000 Subject: [PATCH] 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/ (cherry picked from commit 53c524819323dcea8d5e3d56ff4fc6cf49b6c64f) --- .gitignore | 2 - configure.ac | 10 - ocaml/examples/Makefile.am | 25 +- ocaml/examples/README | 4 - ocaml/examples/Throbber.gif | Bin 913 -> 0 bytes ocaml/examples/Throbber.png | Bin 223 -> 0 bytes ocaml/examples/viewer.ml | 706 ------------------------------------- ocaml/examples/xmllight_loader.ml | 16 - ocaml/examples/xmllight_loader.mli | 2 - 9 files changed, 1 insertion(+), 764 deletions(-) delete mode 100644 ocaml/examples/Throbber.gif delete mode 100644 ocaml/examples/Throbber.png delete mode 100644 ocaml/examples/viewer.ml delete mode 100644 ocaml/examples/xmllight_loader.ml delete mode 100644 ocaml/examples/xmllight_loader.mli diff --git a/.gitignore b/.gitignore index 659e70b..575d147 100644 --- a/.gitignore +++ b/.gitignore @@ -170,8 +170,6 @@ ocaml/bindtests 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 diff --git a/configure.ac b/configure.ac index e336d24..349d1ea 100644 --- a/configure.ac +++ b/configure.ac @@ -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"]) -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]) diff --git a/ocaml/examples/Makefile.am b/ocaml/examples/Makefile.am index e38a5c8..c251409 100644 --- a/ocaml/examples/Makefile.am +++ b/ocaml/examples/Makefile.am @@ -1,8 +1,6 @@ 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 @@ -16,25 +14,4 @@ lvs: lvs.ml $(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 diff --git a/ocaml/examples/README b/ocaml/examples/README index 663ab24..679f506 100644 --- a/ocaml/examples/README +++ b/ocaml/examples/README @@ -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. -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 diff --git a/ocaml/examples/Throbber.gif b/ocaml/examples/Throbber.gif deleted file mode 100644 index deac700d4fc776933c8c82026dc246bfc50dceb2..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 913 zcmZ?wbhEHb6k!lyc+9~71X5B`#>U1zK0aw_X$=hxGiT1+v}x0S96<3ux1VcBu(M-; ztC5}oGb2#H;!hSvE(Q(;9gtxlV;NY21x|Xd-pj#oX6v(H0groaGRIZBmUJ$|Yq z%$~;uB-qn00E(YLpglZ?QSF(M_<`vlnt#eI5||oc_AoP$V9$CHQ2ZnU?GZSFYR{Fz z56$TIurnmEG{Njq79hc%^Ae!=DFoUhaun4b5rz*ehtT{Z&XK^@470~sfdqTr%YfpC e0celJF;sg(1U|H)+oLX!z|jJ;C)ohg9%}&U_H8c! diff --git a/ocaml/examples/Throbber.png b/ocaml/examples/Throbber.png deleted file mode 100644 index 7f23bda10352210f9b087c52069b318ee600a451..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 223 zcmeAS@N?(olHy`uVBq!ia0vp^A|TAd3?%E9GuQzsi2$DvS0F7VC1q@E?BnB;mX_Ag z&@gl6%uSm%JusZl29#qg3GxeOaCmkj4a7d=jfz;B<4AnLx7`JYD@< J);T3K0RSM(J}>|P diff --git a/ocaml/examples/viewer.ml b/ocaml/examples/viewer.ml deleted file mode 100644 index 6cd465a..0000000 --- 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.(_)) / .(_)) / .(_)) / }} in - let xs = {{ map xs with - | _ - | _ -> [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 index 6f0c536..0000000 --- a/ocaml/examples/xmllight_loader.ml +++ /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 index 6c7bbe9..0000000 --- a/ocaml/examples/xmllight_loader.mli +++ /dev/null @@ -1,2 +0,0 @@ -val from_file : ?ns:bool -> string -> Ocamlduce.Load.anyxml -val from_string : ?ns:bool -> string -> Ocamlduce.Load.anyxml -- 1.8.3.1