* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
*
* Written by Richard W.M. Jones <rjones@redhat.com>
+ * Python script modified from a version by Seth Vidal.
*)
open Sexplib
(* This corresponds to the sexpr that we write out from the
* Python code. OCaml will type-check it.
*)
-type root_packages = string * packages
+type root_packages = nevra * packages
and packages = pkg list
and pkg = {
- nevra : string; (* name-[epoch:]version-release.arch *)
+ nevra : nevra;
name : string;
epoch : int;
version : string;
release : string;
arch : string;
size : int64; (* installed size, excl. dirs *)
- deps : string list;
+ deps : nevra list;
}
+and nevra = string (* Name-[Epoch:]Version-Release.Arch *)
with sexp
(* Full dependency representation. This is actually a graph because
- * it contains dependency loops. 'deps list' is a ref because we
- * update it as we are building it.
+ * it contains dependency loops. The only difference from the pkg
+ * structure is that we have resolved the nevra strings into direct
+ * links, so we can quickly recurse over the tree.
+ *
+ * Parents/deps are mutable only because we want to modify these
+ * lists when creating this graph in 'create_deps'.
*)
-type deps = Deps of pkg * deps list ref
+type deps = {
+ pkg : pkg; (* the package *)
+ mutable children : deps list; (* dependencies of this package (below) *)
+ mutable parents : deps list; (* parents of this package (above) *)
+}
(* Final tree representation, loops removed, and everything we want to
* display stored in the nodes.
*)
-type tree = Tree of pkg * int64 * int64 * tree list
+type tree = Tree of pkg * int64 * int64 * GDraw.color * tree list
+(* Helpful modules, operators and functions. *)
module StringMap = Map.Make (String)
let (+^) = Int64.add
let sum = List.fold_left (+^) 0L
let spaces n = String.make n ' '
+let failwithf = ksprintf failwith
+
+(* Debugging support (--debug on the command line). *)
+let debug_flag = ref false
+let debug format =
+ (* ifprintf consumes the arguments, but produces no output *)
+ (if !debug_flag then eprintf else ifprintf Pervasives.stderr) format
+
+(* Python has privileged access to the yum repodata, so we have to use
+ * this Python snippet to pull the data that we need out. This is the
+ * part of the program that takes ages to run, because Python is as
+ * slow as a fat snake that's just eaten a huge lunch. We can't help
+ * that.
+ *
+ * This function takes a string (package name) and returns a
+ * root_packages type.
+ *)
+let repoquery pkgstr =
+ let py = "
+import yum
+import yum.misc
+import sys
+
+yb = yum.YumBase ()
+
+basepkg = yb.pkgSack.returnPackages (patterns=[sys.argv[1]])[0]
+deps = dict ({basepkg:False})
+
+# Recursively find all the dependencies.
+stable = False
+while not stable:
+ stable = True
+ for pkg in deps.keys():
+ if deps[pkg] == False:
+ deps[pkg] = []
+ stable = False
+ for r in pkg.requires:
+ ps = yb.whatProvides (r[0], r[1], r[2])
+ best = yb._bestPackageFromList (ps.returnPackages ())
+ if best.name != pkg.name:
+ deps[pkg].append (best)
+ if not deps.has_key (best):
+ deps[best] = False
+ deps[pkg] = yum.misc.unique (deps[pkg])
+
+# Get the data out of python as fast as possible so we can
+# use a serious language for analysis of the tree.
+print \"(%s (\" % basepkg
+for pkg in deps.keys():
+ print \"((nevra %s) (name %s) (epoch %s) (version %s) (release %s) (arch %s) (size %s)\" % (pkg, pkg.name, pkg.epoch, pkg.version, pkg.release, pkg.arch, pkg.installedsize)
+ print \"(deps (\"
+ for p in deps[pkg]:
+ print \"%s \" % p,
+ print \")))\"
+sys.stdout.write (\"))\") # suppress trailing newline" in
-let () =
(* Run the Python program and read in the generated sexpr. *)
let cmd =
- sprintf "./repodeps %s" (Filename.quote Sys.argv.(1)) in
+ sprintf "python -c %s %s" (Filename.quote py) (Filename.quote pkgstr) in
let chan = open_process_in cmd in
- ignore (input_line chan); (* drop "Loaded plugins" *)
+ ignore (input_line chan); (* Drop "Loaded plugins" line. *)
let root, pkgs =
root_packages_of_sexp (Sexp.of_string (Std.input_all chan)) in
(match close_process_in chan with
| WEXITED 0 -> ()
- | WEXITED i -> failwith (sprintf "command exited with status %d" i)
+ | WEXITED i -> failwithf "python command exited with status %d" i
| WSIGNALED i | WSTOPPED i ->
- failwith (sprintf "command stopped with signal %d" i)
+ failwithf "python command stopped with signal %d" i
);
- (* Create the dependency graph, probably contains loops so beware. *)
- let deps = List.map (fun pkg -> Deps (pkg, ref [])) pkgs in
+ (root, pkgs)
+
+(* Create the dependency graph from the raw package data. Probably
+ * contains loops so beware.
+ *
+ * Takes the list of packages (from Python code) and returns a
+ * StringMap of nevra -> deps.
+ *)
+let create_deps pkgs =
+ let deps =
+ List.map (fun pkg -> { pkg = pkg; children = []; parents = [] }) pkgs in
let depsmap =
List.fold_left (
- fun map (Deps (pkg, _) as deps) ->
- StringMap.add pkg.nevra deps map
+ fun map ({pkg = pkg} as deps) -> StringMap.add pkg.nevra deps map
) StringMap.empty deps in
List.iter (
- fun (Deps (pkg, deps)) ->
- let deps' = List.map (fun n -> StringMap.find n depsmap) pkg.deps in
- deps := List.append !deps deps'
+ fun dep ->
+ List.iter (
+ fun nevra ->
+ let dep' = StringMap.find nevra depsmap in
+ (* dep.pkg is parent of dep'.pkg *)
+ dep.children <- dep' :: dep.children;
+ dep'.parents <- dep :: dep'.parents
+ ) dep.pkg.deps;
) deps;
+ depsmap
- (* For each package, calculate the total installed size of the package,
- * which includes all subpackages pulled in. So it's what would be
- * installed if you did 'yum install foo'.
- *)
+(* For each package, calculate the total installed size of the package,
+ * which includes all subpackages pulled in. So it's what would be
+ * installed if you did 'yum install foo'.
+ *
+ * Takes the list of packages and the dependency map (see 'create_deps')
+ * and returns a StringMap of nevra -> total.
+ *)
+let create_totals pkgs depsmap =
let total pkg =
let seen = ref StringMap.empty in
let rec _total = function
- | Deps (pkg, _) when StringMap.mem pkg.nevra !seen -> 0L
- | Deps (pkg, { contents = children }) ->
+ | { pkg = pkg } when StringMap.mem pkg.nevra !seen -> 0L
+ | { pkg = pkg; children = children } ->
seen := StringMap.add pkg.nevra true !seen;
pkg.size +^ sum (List.map _total children)
in
List.fold_left (
fun map pkg -> StringMap.add pkg.nevra (total pkg) map
) StringMap.empty pkgs in
+ totalsmap
- (* Create the final display tree. Each node is sorted so that
- * children with the largest contribution come first (on the left).
- * We remove packages which are already installed by earlier
- * (leftward) packages. At each node we also store total size and
- * size of the additional packages.
- *)
+(* Create the final display tree. Each node is sorted so that
+ * children with the largest contribution come first (on the left).
+ * We remove packages which are already installed by earlier
+ * (leftward) packages. At each node we also store total size and
+ * size of the additional packages.
+ *
+ * Takes the nevra of the root package, the depsmap (see 'create_deps')
+ * and the totalsmap (see 'create_totals'), and returns the display
+ * tree and the depth of the tree.
+ *)
+let create_tree root depsmap totalsmap =
let tree =
- let seen = ref StringMap.empty in
+ let seen = StringMap.empty in
+ let seen = StringMap.add root true seen in
+ let seen = ref seen in
+ let mark_seen { pkg = pkg } = seen := StringMap.add pkg.nevra true !seen in
+ let not_seen { pkg = pkg } = not (StringMap.mem pkg.nevra !seen) in
let rec build_tree = function
- | Deps (pkg, _) when StringMap.mem pkg.nevra !seen -> None
- | Deps (pkg, { contents = children }) ->
+ | { pkg = pkg; children = children } ->
(* Sort children by reverse total size. *)
- let cmp (Deps (p1, _)) (Deps (p2, _)) =
+ let cmp { pkg = p1 } { pkg = p2 } =
let t1 = StringMap.find p1.nevra totalsmap in
let t2 = StringMap.find p2.nevra totalsmap in
compare t2 t1
in
let children = List.sort ~cmp children in
- seen := StringMap.add pkg.nevra true !seen;
- let children = List.filter_map build_tree children in
+ let children = List.filter not_seen children in
+ List.iter mark_seen children;
+ let children = List.map build_tree children in
let total = StringMap.find pkg.nevra totalsmap in
- let childadditional =
+ let increm =
let rec sum_child_sizes = function
- | Tree (pkg, _, _, children) ->
+ | Tree (pkg, _, _, _, children) ->
List.fold_left (
fun size child -> size +^ sum_child_sizes child
) pkg.size children
in
- sum_child_sizes (Tree (pkg, 0L, 0L, children)) in
- Some (Tree (pkg, total, childadditional, children))
+ sum_child_sizes (Tree (pkg, 0L, 0L, `WHITE, children)) in
+ Tree (pkg, total, increm, `WHITE, children)
+ in
+ build_tree (StringMap.find root depsmap) in
+
+ (* Max depth of the tree. *)
+ let depth =
+ let rec depth = function
+ | Tree (pkg, _, _, _, children) ->
+ List.fold_left (fun d c -> max d (1 + depth c)) 1 children
+ in
+ depth tree in
+
+ (* Allocate a colour to each node in the tree based on its parent. The
+ * single top node is always light grey. The second level nodes are
+ * primary colours.
+ *)
+ let tree =
+ let Tree (pkg, total, increm, _, level2) = tree in
+ let level2 =
+ let pcols = [
+ `RGB (55000, 0, 0);
+ `RGB (0, 55000, 0);
+ `RGB (0, 0, 55000);
+ `RGB (55000, 55000, 0);
+ `RGB (0, 55000, 55000);
+ ] in
+ let rec colour_level2 cols = function
+ | [] -> []
+ | Tree (pkg, total, increm, _, level3) :: level2 ->
+ let col, cols = match cols with
+ | [] -> List.hd pcols, List.tl pcols
+ | col :: cols -> col, cols in
+ let level3 = colour_level3 col (List.length level3) 0 level3 in
+ Tree (pkg, total, increm, col, level3)
+ :: colour_level2 cols level2
+ and colour_level3 col n i = function
+ | [] -> []
+ | Tree (pkg, total, increm, _, leveln) :: level3 ->
+ let col = scale_colour col n i in
+ let leveln = colour_level3 col (List.length leveln) 0 leveln in
+ Tree (pkg, total, increm, col, leveln)
+ :: colour_level3 col n (i+1) level3
+ and scale_colour col n i =
+ let r, g, b = match col with
+ | `RGB (r, g, b) -> float r, float g, float b
+ | _ -> assert false in
+ let i = float i and n = float n in
+ let scale = 0.8 +. i/.(5.*.n) in
+ let r = r *. scale in
+ let g = g *. scale in
+ let b = b *. scale in
+ `RGB (int_of_float r, int_of_float g, int_of_float b)
+ in
+ colour_level2 pcols level2 in
+ Tree (pkg, total, increm, `RGB (55000, 55000, 55000), level2) in
+
+ tree, depth
+
+(* Debugging functions. These only produce any output if debugging
+ * was enabled on the command line.
+ *)
+let debug_pkgs root pkgs =
+ if !debug_flag then (
+ List.iter (
+ fun pkg ->
+ eprintf "%s -> [%s]\n" pkg.nevra (String.concat ", " pkg.deps)
+ ) pkgs;
+ eprintf "root package is %s\n" root;
+ eprintf "===\n%!"
+ )
+
+let debug_deps root depsmap =
+ if !debug_flag then (
+ let seen = ref StringMap.empty in
+ let rec display ?(indent=0) = function
+ | { pkg = pkg; children = children; parents = parents } ->
+ if StringMap.mem pkg.nevra !seen then
+ eprintf "%s%s -> ...\n" (spaces indent) pkg.nevra
+ else (
+ eprintf "%s%s ->\n%sparents:[%s]\n"
+ (spaces indent) pkg.nevra (spaces (indent+2)) (
+ String.concat ", "
+ (List.map (fun { pkg = pkg } -> pkg.nevra) parents)
+ );
+ seen := StringMap.add pkg.nevra true !seen;
+ List.iter (display ~indent:(indent+2)) children
+ )
in
- Option.get (build_tree (StringMap.find root depsmap)) in
-
- (* Display tree. *)
- let rec display ?(indent=0) = function
- | Tree (pkg, total, childadditional, children) ->
- printf "%s%s %Ld/%Ld/%Ld\n"
- (spaces indent) pkg.nevra pkg.size childadditional total;
- List.iter (display ~indent:(indent+2)) children
+ display (StringMap.find root depsmap);
+ eprintf "===\n%!"
+ )
+
+let debug_tree tree =
+ if !debug_flag then (
+ let rec display ?(indent=0) = function
+ | Tree (pkg, total, increm, _, children) ->
+ eprintf "%s%s %Ld/%Ld/%Ld\n%!"
+ (spaces indent) pkg.nevra pkg.size increm total;
+ List.iter (display ~indent:(indent+2)) children
+ in
+ display tree;
+ )
+
+(* Useful display functions. *)
+let display_percent bytes top_total =
+ 100. *. Int64.to_float bytes /. Int64.to_float top_total
+
+let display_size bytes =
+ if bytes > 104_857L then
+ sprintf "%.1f MB" (Int64.to_float bytes /. 1_048_576.)
+ else if bytes > 102L then
+ sprintf "%.1f KB" (Int64.to_float bytes /. 1_024.)
+ else
+ sprintf "%Ld" bytes
+
+(* Defer a function callback until Gtk rendering has been done. *)
+let defer ?(ms=10) f =
+ ignore (GMain.Timeout.add ~ms ~callback:(fun () -> f (); false))
+
+(* Open the toplevel window. The 'pkgstr' parameter is the optional
+ * name of the package to open. If None then we open a blank window.
+ *)
+let open_window pkgstr =
+ (* Open the window. *)
+ let base_title = "Fedora RPM dependency size viewer" in
+ let window =
+ GWindow.window ~width:800 ~height:600
+ ~title:base_title ~allow_shrink:true () in
+
+ let vbox = GPack.vbox ~packing:window#add () in
+
+ (* Menu bar. *)
+ let menubar = GMenu.menu_bar ~packing:vbox#pack () in
+ let factory = new GMenu.factory menubar in
+ let accel_group = factory#accel_group in
+ let package_menu = factory#add_submenu "_Package" in
+ let help_menu = factory#add_submenu "_Help" in
+
+ let factory = new GMenu.factory package_menu ~accel_group in
+ let open_item = factory#add_item "_Open package ..." ~key:GdkKeysyms._O in
+ let quit_item = factory#add_item "E_xit" ~key:GdkKeysyms._Q in
+
+ let factory = new GMenu.factory help_menu ~accel_group in
+ let about_item = factory#add_item "About" in
+
+ (* Events for the menu bar. *)
+ ignore (window#connect#destroy ~callback:GMain.quit);
+ ignore (quit_item#connect#activate ~callback:GMain.quit);
+
+ ignore (about_item#connect#activate ~callback:Rpmdepsize_about.callback);
+
+ 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);
+
+ (* 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");
+
+ (* This is the currently open package, or None if nothing has
+ * opened by the user yet.
+ *)
+ let opened = ref None in
+
+ (* Called from the "Open package" menu entry and other places. *)
+ let open_package pkgstr =
+ debug "open_package %s\n%!" pkgstr;
+
+ (* XXX Can't be bothered to do this "properly" (ie with threads etc)
+ * so just put a loading message in the middle of the drawing area.
+ *)
+ let width, height = draw#size in
+ let txt = pango_large_context#create_layout in
+ Pango.Layout.set_text txt (sprintf "Loading %s ..." pkgstr);
+ let { Pango.width = txtwidth; Pango.height = txtheight } =
+ Pango.Layout.get_pixel_extent txt in
+ let x = (width - txtwidth) / 2 and y = (height - txtheight) / 2 in
+ draw#set_foreground (`RGB (0, 0, 65535));
+ draw#rectangle ~x:(x-4) ~y:(y-2)
+ ~width:(txtwidth+8) ~height:(txtheight+8) ~filled:true ();
+ draw#put_layout ~x ~y ~fore:`WHITE txt;
+
+ defer (
+ fun () ->
+ let root, pkgs = repoquery pkgstr in
+ debug_pkgs root pkgs;
+ let depsmap = create_deps pkgs in
+ debug_deps root depsmap;
+ let totalsmap = create_totals pkgs depsmap in
+ let tree, depth = create_tree root depsmap totalsmap in
+ debug_tree tree;
+
+ (* top_total is the total size in bytes of everything. Used for
+ * relative display of percentages, widths, etc.
+ *)
+ let Tree (_, top_total, top_increm, _, _) = tree in
+ assert (top_total = top_increm);
+
+ opened :=
+ Some (root, pkgs, depsmap, totalsmap, tree, depth, top_total);
+
+ (* Update the window title. *)
+ window#set_title (pkgstr ^ " - " ^ base_title);
+
+ (* Force a repaint of the drawing area. *)
+ GtkBase.Widget.queue_draw da#as_widget;
+ )
+ in
+
+ (* If the user selected something on the command line (pkgstr !=
+ * None) then set up an idle event to populate 'opened' as soon as
+ * the window gets drawn on the screen.
+ *)
+ (match pkgstr with
+ | None -> ()
+ | Some pkgstr ->
+ defer ~ms:50 (fun () -> open_package pkgstr)
+ );
+
+ let callback _ =
+ let dlg =
+ GWindow.dialog ~parent:window ~modal:true
+ ~position:`CENTER_ON_PARENT ~title:"Open package" () in
+ dlg#add_button "Open package" `OPEN;
+ dlg#add_button "Cancel" `CANCEL;
+ let vbox = dlg#vbox in
+ let hbox = GPack.hbox ~packing:vbox#pack () in
+ ignore (GMisc.label ~text:"Package:" ~packing:hbox#pack ());
+ let entry = GEdit.entry
+ ~width_chars:40 ~packing:(hbox#pack ~expand:true ~fill:true) () in
+ ignore (GMisc.label ~text:"Enter a package name, wildcard or path."
+ ~packing:vbox#pack ());
+ dlg#show ();
+ match dlg#run () with
+ | `CANCEL | `DELETE_EVENT ->
+ dlg#destroy ()
+ | `OPEN ->
+ let pkgstr = entry#text in
+ dlg#destroy ();
+ if pkgstr <> "" then
+ defer (fun () -> open_package pkgstr)
+ in
+ ignore (open_item#connect#activate ~callback);
+
+ (* Need to enable these mouse events so we can do tooltips. *)
+ GtkBase.Widget.add_events da#as_widget
+ [`ENTER_NOTIFY; `LEAVE_NOTIFY; `POINTER_MOTION];
+
+ let tooltips = ref None in
+
+ (* To track tooltips, the 'repaint' function records the location of
+ * each box (ie. package) in the drawing area in this private data
+ * structure, and the 'motion' function looks them up in order to
+ * display the right tooltip over each box.
+ *)
+ let add_locn, reset_locns, get_locn =
+ let rows = ref [||] in
+ let rowheight = ref 0. in
+
+ let reset_locns rowheight' depth =
+ (* This data structure sucks because we just do a linear search
+ * over each row when looking up the 'x'. Should use some sort
+ * of self-balancing tree instead. XXX
+ *)
+ rows := Array.init depth (fun _ -> ref []);
+ rowheight := rowheight'
+ and add_locn x yi width thing =
+ let row = (!rows).(yi) in
+ row := ((x, x +. width), thing) :: !row
+ and get_locn x y =
+ let yi = int_of_float (y /. !rowheight) in
+ if yi >= 0 && yi < Array.length !rows then (
+ let row = !((!rows).(yi)) in
+ try Some
+ (snd (List.find (fun ((xlow, xhi), thing) ->
+ xlow <= x && x < xhi)
+ row))
+ with Not_found -> None
+ )
+ else None
+ in
+ add_locn, reset_locns, get_locn
in
- display tree
+
+ let rec real_repaint root pkgs depsmap totalsmap tree depth top_total =
+ (* Get the canvas size and fill the background with white. *)
+ let width, height = draw#size in
+ draw#set_background `WHITE;
+ draw#set_foreground `WHITE;
+ draw#rectangle ~x:0 ~y:0 ~width ~height ~filled:true ();
+
+ (* Calculate the scales so we can fit everything into the window. *)
+ let rowheight = float height /. float depth in
+ let scale = float width /. Int64.to_float top_total in
+
+ reset_locns rowheight depth;
+
+ (* Now draw the tree. *)
+ let rec draw_tree x yi = function
+ | Tree (pkg, total, increm, colour, children) ->
+ (* Draw pkg at (x, y). *)
+ let y = float yi *. rowheight in
+ let width = scale *. Int64.to_float increm in
+ let pkgsizewidth = scale *. Int64.to_float pkg.size in
+ draw_pkg x yi y width pkgsizewidth rowheight colour pkg total increm;
+
+ (* Draw the children of pkg at (i, y + rowheight), where
+ * i starts as x and increments for each child.
+ *)
+ let yi = yi + 1 in
+ let rec loop x = function
+ | [] -> ()
+ | child :: children ->
+ draw_tree x yi child;
+ let Tree (_, _, increm, _, _) = child in
+ let childwidth = scale *. Int64.to_float increm in
+ loop (x +. childwidth) children
+ in
+ loop x children
+
+ (* Draw a single package. *)
+ and draw_pkg x yi y width pkgsizewidth height colour pkg total increm =
+ add_locn x yi width (colour, pkg, total, increm);
+
+ let x = int_of_float x in
+ let y = int_of_float y in
+ let width = int_of_float width in
+ let pkgsizewidth = int_of_float pkgsizewidth in
+ let height = int_of_float height in
+
+ if width > 8 then (
+ draw_pkg_outline x y width pkgsizewidth height colour;
+ draw_pkg_label x y width height colour pkg total increm
+ )
+ else if width >= 4 then
+ draw_pkg_narrow x y width height colour
+ (* else
+ XXX This doesn't work. We need to coalesce small packages
+ in the tree.
+ draw_pkg_narrow x y 1 height colour *)
+
+ and draw_pkg_outline x y width pkgsizewidth height colour =
+ draw#set_foreground colour;
+ draw#rectangle ~x:(x+2) ~y:(y+2)
+ ~width:(width-4) ~height:(height-4)
+ ~filled:true ();
+ if pkgsizewidth > 2 then (
+ draw#set_foreground (darken colour);
+ draw#rectangle ~x:(x+2) ~y:(y+2)
+ ~width:(pkgsizewidth-2) ~height:(height-4)
+ ~filled:true ();
+ draw#set_foreground (choose_contrasting_colour colour);
+ draw#set_line_attributes ~style:`ON_OFF_DASH ();
+ draw#line (x+pkgsizewidth) (y+2) (x+pkgsizewidth) (y+height-2);
+ draw#set_line_attributes ~style:`SOLID ()
+ );
+ draw#set_foreground (`BLACK);
+ draw#rectangle ~x:(x+2) ~y:(y+2)
+ ~width:(width-4) ~height:(height-4)
+ ~filled:false ()
+
+ and draw_pkg_label x y width height colour pkg total increm =
+ (* How to write text in a drawing area, in case it's not
+ * obvious, which it certainly is not:
+ * http://www.math.nagoya-u.ac.jp/~garrigue/soft/olabl/lablgtk-list/120.txt
+ *)
+ (* txt1 is the same as the tooltip. *)
+ let txt1 = lazy (
+ let txt = pango_large_context#create_layout in
+ Pango.Layout.set_text txt (
+ sprintf "%s
+Package: %.1f%% %s (%Ld bytes)
+Incremental: %.1f%% %s (%Ld bytes)
+Total: %.1f%% %s (%Ld bytes)" pkg.nevra
+ (display_percent pkg.size top_total) (display_size pkg.size) pkg.size
+ (display_percent increm top_total) (display_size increm) increm
+ (display_percent total top_total) (display_size total) total
+ );
+ txt
+ )
+ and txt2 = lazy (
+ let txt = pango_small_context#create_layout in
+ Pango.Layout.set_text txt (
+ sprintf "%s
+Package: %.1f%% %s (%Ld bytes)
+Incremental: %.1f%% %s (%Ld bytes)
+Total: %.1f%% %s (%Ld bytes)" pkg.nevra
+ (display_percent pkg.size top_total) (display_size pkg.size) pkg.size
+ (display_percent increm top_total) (display_size increm) increm
+ (display_percent total top_total) (display_size total) total
+ );
+ txt
+ )
+ and txt3 = lazy (
+ let txt = pango_small_context#create_layout in
+ Pango.Layout.set_text txt (
+ sprintf "%s
+Pkg: %.1f%% %s (%Ld bytes)
+Incr: %.1f%% %s (%Ld bytes)
+Tot: %.1f%% %s (%Ld bytes)" pkg.name
+ (display_percent pkg.size top_total) (display_size pkg.size) pkg.size
+ (display_percent increm top_total) (display_size increm) increm
+ (display_percent total top_total) (display_size total) total
+ );
+ txt
+ )
+ and txt4 = lazy (
+ let txt = pango_small_context#create_layout in
+ Pango.Layout.set_text txt (
+ sprintf "%s
+Pkg: %.1f%% %s
+Incr: %.1f%% %s
+Tot: %.1f%% %s" pkg.name
+ (display_percent pkg.size top_total) (display_size pkg.size)
+ (display_percent increm top_total) (display_size increm)
+ (display_percent total top_total) (display_size total)
+ );
+ txt
+ )
+ and txt5 = lazy (
+ let txt = pango_small_context#create_layout in
+ Pango.Layout.set_text txt (
+ sprintf "%s\nPkg: %.1f%%\nIncr: %.1f%%\nTot: %.1f%%"
+ pkg.name
+ (display_percent pkg.size top_total)
+ (display_percent increm top_total)
+ (display_percent total top_total)
+ );
+ txt
+ )
+ and txt6 = lazy (
+ let txt = pango_small_context#create_layout in
+ Pango.Layout.set_text txt (
+ sprintf "%s Pkg: %.1f%% %s Incr: %.1f%% %s Tot: %.1f%% %s" pkg.name
+ (display_percent pkg.size top_total) (display_size pkg.size)
+ (display_percent increm top_total) (display_size increm)
+ (display_percent total top_total) (display_size total)
+ );
+ txt
+ )
+ and txt7 = lazy (
+ let txt = pango_small_context#create_layout in
+ Pango.Layout.set_text txt (
+ sprintf "%s %.1f%% %.1f%% %.1f%%" pkg.name
+ (display_percent pkg.size top_total)
+ (display_percent increm top_total)
+ (display_percent total top_total)
+ );
+ txt
+ )
+ and txt8 = lazy (
+ let txt = pango_small_context#create_layout in
+ Pango.Layout.set_text txt (
+ sprintf "%s" pkg.name
+ );
+ txt
+ ) in
+ let txts = [ txt1; txt2; txt3; txt4; txt5; txt6; txt7; txt8 ] in
+
+ let fore = choose_contrasting_colour colour in
+
+ let rec loop = function
+ | [] -> ()
+ | txt :: txts ->
+ let txt = Lazy.force txt in
+ let { Pango.width = txtwidth;
+ Pango.height = txtheight } =
+ Pango.Layout.get_pixel_extent txt in
+ (* Now with added fudge-factor. *)
+ if width >= txtwidth + 8 && height >= txtheight + 8 then
+ draw#put_layout ~x:(x+4) ~y:(y+4) ~fore txt
+ else loop txts
+ in
+ loop txts
+
+ and draw_pkg_narrow x y width height colour =
+ draw#set_foreground colour;
+ draw#rectangle ~x:(x+2) ~y:(y+2)
+ ~width:(width-4) ~height:(height-4) ~filled:true ()
+
+ and choose_contrasting_colour = function
+ | `RGB (r, g, b) ->
+ if r + g + b > 98304 then `BLACK else `WHITE
+ | _ -> `WHITE
+
+ and darken = function
+ | `RGB (r, g, b) ->
+ `RGB (r * 9 / 10, g * 9 / 10, b * 9 / 10)
+ | _ -> `WHITE
+ in
+ draw_tree 0. 0 tree
+
+ and repaint _ =
+ (match !opened with
+ | None -> ()
+ | Some (root, pkgs, depsmap, totalsmap, tree, depth, top_total) ->
+ real_repaint root pkgs depsmap totalsmap tree depth top_total
+ );
+
+ (* Return false because this is a Gtk event handler. *)
+ false
+ in
+ ignore (da#event#connect#expose ~callback:repaint);
+
+ let rec real_motion root pkgs depsmap totalsmap tree depth top_total ev =
+ let x, y = GdkEvent.Motion.x ev, GdkEvent.Motion.y ev in
+
+ let kill_tooltip () =
+ (match !tooltips with
+ | None -> ()
+ | Some (tt : GData.tooltips) ->
+ tt#set_tip ~text:"" (da :> GObj.widget);
+ tt#disable ()
+ );
+ tooltips := None
+ in
+
+ (match get_locn x y with
+ | None ->
+ kill_tooltip ()
+ | Some (colour, pkg, total, increm) ->
+ (* The only way to make the tooltip follow the mouse is to
+ * kill the whole tooltips object and recreate it each time ...
+ *)
+ kill_tooltip ();
+ let tt = GData.tooltips ~delay:100 () in
+ (* Tooltip text is the same as txt1. *)
+ let text = sprintf "%s
+Package: %.1f%% %s (%Ld bytes)
+Incremental: %.1f%% %s (%Ld bytes)
+Total: %.1f%% %s (%Ld bytes)" pkg.nevra
+ (display_percent pkg.size top_total) (display_size pkg.size) pkg.size
+(display_percent increm top_total) (display_size increm) increm
+(display_percent total top_total) (display_size total) total in
+ tt#set_tip ~text (da :> GObj.widget);
+ tt#enable ();
+ tooltips := Some tt
+ )
+
+ and motion ev =
+ (match !opened with
+ | None -> ()
+ | Some (root, pkgs, depsmap, totalsmap, tree, depth, top_total) ->
+ real_motion root pkgs depsmap totalsmap tree depth top_total ev
+ );
+
+ (* Return false because this is a Gtk event handler. *)
+ false
+ in
+ ignore (da#event#connect#motion_notify ~callback:motion);
+
+ window#add_accel_group accel_group;
+ window#show ();
+ GMain.main ()
+
+(* Main program. *)
+let () =
+ (* Parse the command line arguments. *)
+ let anon_args = ref [] in
+
+ let argspec = Arg.align [
+ "--debug", Arg.Set debug_flag,
+ " " ^ "Enable debugging messages on stderr";
+ ] in
+ let anon_fun str = anon_args := str :: !anon_args in
+ let usage_msg =
+ "rpmdepsize [package] : visualize the size of RPM dependencies" in
+
+ Arg.parse argspec anon_fun usage_msg;
+
+ (* Should be at most one anonymous argument. *)
+ let pkgstr =
+ match !anon_args with
+ | [] -> None
+ | [p] -> Some p
+ | _ ->
+ eprintf "rpmdepsize: too many command line arguments";
+ exit 1 in
+
+ (* Open the main window. *)
+ open_window pkgstr