open Unix
open Printf
+let debug = true
+
(* This corresponds to the sexpr that we write out from the
* Python code. OCaml will type-check it.
*)
(* 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
module StringMap = Map.Make (String)
let (+^) = Int64.add
let sum = List.fold_left (+^) 0L
let spaces n = String.make n ' '
+(* 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.
+ *)
+let repoquery_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"
+
let () =
+ printf "getting repository information (this can take a few seconds ...)\n%!";
+
(* 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 repoquery_py) (Filename.quote Sys.argv.(1)) in
let chan = open_process_in cmd in
ignore (input_line chan); (* drop "Loaded plugins" *)
let root, pkgs =
seen := StringMap.add pkg.nevra true !seen;
let children = List.filter_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
+ Some (Tree (pkg, total, increm, `WHITE, 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
+ if debug then (
+ let rec display ?(indent=0) = function
+ | Tree (pkg, total, increm, _, children) ->
+ printf "%s%s %Ld/%Ld/%Ld\n%!"
+ (spaces indent) pkg.nevra pkg.size increm total;
+ List.iter (display ~indent:(indent+2)) children
+ in
+ display tree
+ );
+
+ (* 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
+
+ (* Open the window. *)
+ let title = root ^ " - Fedora RPM dependency size viewer" in
+ let window =
+ GWindow.window ~width:800 ~height:600 ~title ~allow_shrink:true () in
+
+ ignore (window#connect#destroy ~callback:GMain.quit);
+
+ let da = GMisc.drawing_area ~packing:window#add () in
+ da#misc#realize ();
+ let draw = new GDraw.drawable da#misc#window 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");
+
+ let repaint _ =
+ (* 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 Tree (_, top_total, top_increm, _, _) = tree in
+ assert (top_total = top_increm);
+ let rowheight = float height /. float depth in
+ let scale = float width /. Int64.to_float top_increm in
+
+ (* Now draw the tree. *)
+ let rec draw_tree y x = function
+ | Tree (pkg, total, increm, colour, children) ->
+ (* Draw pkg at (x, y). *)
+ let width = scale *. Int64.to_float increm in
+ let pkgsizewidth = scale *. Int64.to_float pkg.size in
+ draw_pkg x 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 y = y +. rowheight in
+ let rec loop x = function
+ | [] -> ()
+ | child :: children ->
+ draw_tree y x 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 y width pkgsizewidth height 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 nothing *)
+
+ 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
+ *)
+ 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) (display_size pkg.size) pkg.size
+(display_percent increm) (display_size increm) increm
+(display_percent 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) (display_size pkg.size) pkg.size
+(display_percent increm) (display_size increm) increm
+(display_percent 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) (display_size pkg.size) pkg.size
+(display_percent increm) (display_size increm) increm
+(display_percent 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) (display_size pkg.size)
+(display_percent increm) (display_size increm)
+(display_percent 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)
+ (display_percent increm)
+ (display_percent 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) (display_size pkg.size)
+ (display_percent increm) (display_size increm)
+ (display_percent 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)
+ (display_percent increm)
+ (display_percent 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
+
+ and display_percent bytes =
+ 100. *. Int64.to_float bytes /. Int64.to_float top_total
+
+ and 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
+ in
+ draw_tree 0. 0. tree;
+
+ (* Return false because this is a Gtk event handler. *)
+ false
in
- display tree
+ ignore (da#event#connect#expose ~callback:repaint);
+
+ window#show ();
+ GMain.main ()
git.annexia.org / rpmdepsize.git / blobdiff