rpmdepsize.ml

   1 (* rpmdepsize - visualize the size of RPM dependencies
   2  * (C) Copyright 2009 Red Hat Inc.
   3  *
   4  * This program is free software; you can redistribute it and/or modify
   5  * it under the terms of the GNU General Public License as published by
   6  * the Free Software Foundation; either version 2 of the License, or
   7  * (at your option) any later version.
   8  *
   9  * This program is distributed in the hope that it will be useful,
  10  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12  * GNU General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU General Public License
  15  * along with this program; if not, write to the Free Software
  16  * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  17  *
  18  * Written by Richard W.M. Jones <rjones@redhat.com>
  19  * Python script modified from a version by Seth Vidal.
  20  *)
  21
  22 open Sexplib
  23 TYPE_CONV_PATH "."
  24
  25 open ExtList
  26 open Unix
  27 open Printf
  28
  29 (* This corresponds to the sexpr that we write out from the
  30  * Python code.  OCaml will type-check it.
  31  *)
  32 type root_packages = nevra * packages
  33 and packages = pkg list
  34 and pkg = {
  35   nevra : nevra;
  36   name : string;
  37   epoch : int;
  38   version : string;
  39   release : string;
  40   arch : string;
  41   size : int64;                         (* installed size, excl. dirs *)
  42   deps : nevra list;
  43 }
  44 and nevra = string                      (* Name-[Epoch:]Version-Release.Arch *)
  45  with sexp
  46
  47 (* Full dependency representation.  This is actually a graph because
  48  * it contains dependency loops.  The only difference from the pkg
  49  * structure is that we have resolved the nevra strings into direct
  50  * links, so we can quickly recurse over the tree.
  51  *
  52  * Parents/deps are mutable only because we want to modify these
  53  * lists when creating this graph in 'create_deps'.
  54  *)
  55 type deps = {
  56   pkg : pkg;                    (* the package *)
  57   mutable children : deps list; (* dependencies of this package (below) *)
  58   mutable parents : deps list;  (* parents of this package (above) *)
  59 }
  60
  61 (* Final tree representation, loops removed, and everything we want to
  62  * display stored in the nodes.
  63  *)
  64 type tree = Tree of pkg * int64 * int64 * GDraw.color * tree list
  65
  66 (* Helpful modules, operators and functions. *)
  67 module StringMap = Map.Make (String)
  68 let (+^) = Int64.add
  69 let sum = List.fold_left (+^) 0L
  70 let spaces n = String.make n ' '
  71 let failwithf = ksprintf failwith
  72
  73 (* Debugging support (--debug on the command line). *)
  74 let debug_flag = ref false
  75 let debug format =
  76   (* ifprintf consumes the arguments, but produces no output *)
  77   (if !debug_flag then eprintf else ifprintf Pervasives.stderr) format
  78
  79 (* Python has privileged access to the yum repodata, so we have to use
  80  * this Python snippet to pull the data that we need out.  This is the
  81  * part of the program that takes ages to run, because Python is as
  82  * slow as a fat snake that's just eaten a huge lunch.  We can't help
  83  * that.
  84  *
  85  * This function takes a string (package name) and returns a
  86  * root_packages type.
  87  *)
  88 let repoquery pkgstr =
  89   let py = "
  90 import yum
  91 import yum.misc
  92 import sys
  93
  94 yb = yum.YumBase ()
  95
  96 basepkg = yb.pkgSack.returnPackages (patterns=[sys.argv[1]])[0]
  97 deps = dict ({basepkg:False})
  98
  99 # Recursively find all the dependencies.
 100 stable = False
 101 while not stable:
 102     stable = True
 103     for pkg in deps.keys():
 104         if deps[pkg] == False:
 105             deps[pkg] = []
 106             stable = False
 107             for r in pkg.requires:
 108                 ps = yb.whatProvides (r[0], r[1], r[2])
 109                 best = yb._bestPackageFromList (ps.returnPackages ())
 110                 if best.name != pkg.name:
 111                     deps[pkg].append (best)
 112                     if not deps.has_key (best):
 113                         deps[best] = False
 114             deps[pkg] = yum.misc.unique (deps[pkg])
 115
 116 # Get the data out of python as fast as possible so we can
 117 # use a serious language for analysis of the tree.
 118 print \"(%s (\" % basepkg
 119 for pkg in deps.keys():
 120     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)
 121     print \"(deps (\"
 122     for p in deps[pkg]:
 123         print \"%s \" % p,
 124     print \")))\"
 125 sys.stdout.write (\"))\")  # suppress trailing newline" in
 126
 127   (* Run the Python program and read in the generated sexpr. *)
 128   let cmd =
 129     sprintf "python -c %s %s" (Filename.quote py) (Filename.quote pkgstr) in
 130   let chan = open_process_in cmd in
 131   ignore (input_line chan); (* Drop "Loaded plugins" line. *)
 132   let root, pkgs =
 133     root_packages_of_sexp (Sexp.of_string (Std.input_all chan)) in
 134   (match close_process_in chan with
 135    | WEXITED 0 -> ()
 136    | WEXITED i -> failwithf "python command exited with status %d" i
 137    | WSIGNALED i | WSTOPPED i ->
 138        failwithf "python command stopped with signal %d" i
 139   );
 140
 141   (root, pkgs)
 142
 143 (* Create the dependency graph from the raw package data.  Probably
 144  * contains loops so beware.
 145  *
 146  * Takes the list of packages (from Python code) and returns a
 147  * StringMap of nevra -> deps.
 148  *)
 149 let create_deps pkgs =
 150   let deps =
 151     List.map (fun pkg -> { pkg = pkg; children = []; parents = [] }) pkgs in
 152   let depsmap =
 153     List.fold_left (
 154       fun map ({pkg = pkg} as deps) -> StringMap.add pkg.nevra deps map
 155     ) StringMap.empty deps in
 156   List.iter (
 157     fun dep ->
 158       List.iter (
 159         fun nevra ->
 160           let dep' = StringMap.find nevra depsmap in
 161           (* dep.pkg is parent of dep'.pkg *)
 162           dep.children <- dep' :: dep.children;
 163           dep'.parents <- dep :: dep'.parents
 164       ) dep.pkg.deps;
 165   ) deps;
 166   depsmap
 167
 168 (* For each package, calculate the total installed size of the package,
 169  * which includes all subpackages pulled in.  So it's what would be
 170  * installed if you did 'yum install foo'.
 171  *
 172  * Takes the list of packages and the dependency map (see 'create_deps')
 173  * and returns a StringMap of nevra -> total.
 174  *)
 175 let create_totals pkgs depsmap =
 176   let total pkg =
 177     let seen = ref StringMap.empty in
 178     let rec _total = function
 179       | { pkg = pkg } when StringMap.mem pkg.nevra !seen -> 0L
 180       | { pkg = pkg; children = children } ->
 181           seen := StringMap.add pkg.nevra true !seen;
 182           pkg.size +^ sum (List.map _total children)
 183     in
 184     _total (StringMap.find pkg.nevra depsmap)
 185   in
 186   let totalsmap =
 187     List.fold_left (
 188       fun map pkg -> StringMap.add pkg.nevra (total pkg) map
 189     ) StringMap.empty pkgs in
 190   totalsmap
 191
 192 (* Create the final display tree.  Each node is sorted so that
 193  * children with the largest contribution come first (on the left).
 194  * We remove packages which are already installed by earlier
 195  * (leftward) packages.  At each node we also store total size and
 196  * size of the additional packages.
 197  *
 198  * Takes the nevra of the root package, the depsmap (see 'create_deps')
 199  * and the totalsmap (see 'create_totals'), and returns the display
 200  * tree and the depth of the tree.
 201  *)
 202 let create_tree root depsmap totalsmap =
 203   let tree =
 204     let seen = StringMap.empty in
 205     let seen = StringMap.add root true seen in
 206     let seen = ref seen in
 207     let mark_seen { pkg = pkg } = seen := StringMap.add pkg.nevra true !seen in
 208     let not_seen { pkg = pkg } = not (StringMap.mem pkg.nevra !seen) in
 209     let rec build_tree = function
 210       | { pkg = pkg; children = children } ->
 211           (* Sort children by reverse total size. *)
 212           let cmp { pkg = p1 } { pkg = p2 } =
 213             let t1 = StringMap.find p1.nevra totalsmap in
 214             let t2 = StringMap.find p2.nevra totalsmap in
 215             compare t2 t1
 216           in
 217           let children = List.sort ~cmp children in
 218           let children = List.filter not_seen children in
 219           List.iter mark_seen children;
 220           let children = List.map build_tree children in
 221           let total = StringMap.find pkg.nevra totalsmap in
 222           let increm =
 223             let rec sum_child_sizes = function
 224               | Tree (pkg, _, _, _, children) ->
 225                   List.fold_left (
 226                     fun size child -> size +^ sum_child_sizes child
 227                   ) pkg.size children
 228             in
 229             sum_child_sizes (Tree (pkg, 0L, 0L, `WHITE, children)) in
 230           Tree (pkg, total, increm, `WHITE, children)
 231     in
 232     build_tree (StringMap.find root depsmap) in
 233
 234   (* Max depth of the tree. *)
 235   let depth =
 236     let rec depth = function
 237       | Tree (pkg, _, _, _, children) ->
 238           List.fold_left (fun d c -> max d (1 + depth c)) 1 children
 239     in
 240     depth tree in
 241
 242   (* Allocate a colour to each node in the tree based on its parent.  The
 243    * single top node is always light grey.  The second level nodes are
 244    * primary colours.
 245    *)
 246   let tree =
 247     let Tree (pkg, total, increm, _, level2) = tree in
 248     let level2 =
 249       let pcols = [
 250         `RGB (55000, 0, 0);
 251         `RGB (0, 55000, 0);
 252         `RGB (0, 0, 55000);
 253         `RGB (55000, 55000, 0);
 254         `RGB (0, 55000, 55000);
 255       ] in
 256       let rec colour_level2 cols = function
 257         | [] -> []
 258         | Tree (pkg, total, increm, _, level3) :: level2 ->
 259             let col, cols = match cols with
 260               | [] -> List.hd pcols, List.tl pcols
 261               | col :: cols -> col, cols in
 262             let level3 = colour_level3 col (List.length level3) 0 level3 in
 263             Tree (pkg, total, increm, col, level3)
 264             :: colour_level2 cols level2
 265       and colour_level3 col n i = function
 266         | [] -> []
 267         | Tree (pkg, total, increm, _, leveln) :: level3 ->
 268             let col = scale_colour col n i in
 269             let leveln = colour_level3 col (List.length leveln) 0 leveln in
 270             Tree (pkg, total, increm, col, leveln)
 271             :: colour_level3 col n (i+1) level3
 272       and scale_colour col n i =
 273         let r, g, b = match col with
 274           | `RGB (r, g, b) -> float r, float g, float b
 275           | _ -> assert false in
 276         let i = float i and n = float n in
 277         let scale = 0.8 +. i/.(5.*.n) in
 278         let r = r *. scale in
 279         let g = g *. scale in
 280         let b = b *. scale in
 281         `RGB (int_of_float r, int_of_float g, int_of_float b)
 282       in
 283       colour_level2 pcols level2 in
 284     Tree (pkg, total, increm, `RGB (55000, 55000, 55000), level2) in
 285
 286   tree, depth
 287
 288 (* Debugging functions.  These only produce any output if debugging
 289  * was enabled on the command line.
 290  *)
 291 let debug_pkgs root pkgs =
 292   if !debug_flag then (
 293     List.iter (
 294       fun pkg ->
 295         eprintf "%s -> [%s]\n" pkg.nevra (String.concat ", " pkg.deps)
 296     ) pkgs;
 297     eprintf "root package is %s\n" root;
 298     eprintf "===\n%!"
 299   )
 300
 301 let debug_deps root depsmap =
 302   if !debug_flag then (
 303     let seen = ref StringMap.empty in
 304     let rec display ?(indent=0) = function
 305       | { pkg = pkg; children = children; parents = parents } ->
 306           if StringMap.mem pkg.nevra !seen then
 307             eprintf "%s%s -> ...\n" (spaces indent) pkg.nevra
 308           else (
 309             eprintf "%s%s ->\n%sparents:[%s]\n"
 310               (spaces indent) pkg.nevra (spaces (indent+2)) (
 311                 String.concat ", "
 312                   (List.map (fun { pkg = pkg } -> pkg.nevra) parents)
 313               );
 314             seen := StringMap.add pkg.nevra true !seen;
 315             List.iter (display ~indent:(indent+2)) children
 316           )
 317     in
 318     display (StringMap.find root depsmap);
 319     eprintf "===\n%!"
 320   )
 321
 322 let debug_tree tree =
 323   if !debug_flag then (
 324     let rec display ?(indent=0) = function
 325       | Tree (pkg, total, increm, _, children) ->
 326           eprintf "%s%s %Ld/%Ld/%Ld\n%!"
 327             (spaces indent) pkg.nevra pkg.size increm total;
 328           List.iter (display ~indent:(indent+2)) children
 329     in
 330     display tree;
 331   )
 332
 333 (* Useful display functions. *)
 334 let display_percent bytes top_total =
 335   100. *. Int64.to_float bytes /. Int64.to_float top_total
 336
 337 let display_size bytes =
 338   if bytes > 104_857L then
 339     sprintf "%.1f MB" (Int64.to_float bytes /. 1_048_576.)
 340   else if bytes > 102L then
 341     sprintf "%.1f KB" (Int64.to_float bytes /. 1_024.)
 342   else
 343     sprintf "%Ld" bytes
 344
 345 (* Defer a function callback until Gtk rendering has been done. *)
 346 let defer ?(ms=10) f =
 347   ignore (GMain.Timeout.add ~ms ~callback:(fun () -> f (); false))
 348
 349 (* Open the toplevel window.  The 'pkgstr' parameter is the optional
 350  * name of the package to open.  If None then we open a blank window.
 351  *)
 352 let open_window pkgstr =
 353   (* Open the window. *)
 354   let base_title = "Fedora RPM dependency size viewer" in
 355   let window =
 356     GWindow.window ~width:800 ~height:600
 357       ~title:base_title ~allow_shrink:true () in
 358
 359   let vbox = GPack.vbox ~packing:window#add () in
 360
 361   (* Menu bar. *)
 362   let menubar = GMenu.menu_bar ~packing:vbox#pack () in
 363   let factory = new GMenu.factory menubar in
 364   let accel_group = factory#accel_group in
 365   let package_menu = factory#add_submenu "_Package" in
 366   let help_menu = factory#add_submenu "_Help" in
 367
 368   let factory = new GMenu.factory package_menu ~accel_group in
 369   let open_item = factory#add_item "_Open package ..." ~key:GdkKeysyms._O in
 370   let quit_item = factory#add_item "E_xit" ~key:GdkKeysyms._Q in
 371
 372   let factory = new GMenu.factory help_menu ~accel_group in
 373   let about_item = factory#add_item "About" in
 374
 375   (* Events for the menu bar. *)
 376   ignore (window#connect#destroy ~callback:GMain.quit);
 377   ignore (quit_item#connect#activate ~callback:GMain.quit);
 378
 379   ignore (about_item#connect#activate ~callback:Rpmdepsize_about.callback);
 380
 381   let da = GMisc.drawing_area
 382     ~packing:(vbox#pack ~expand:true ~fill:true) () in
 383   da#misc#realize ();
 384   let draw = new GDraw.drawable da#misc#window in
 385
 386   window#set_geometry_hints ~min_size:(80,80) (da :> GObj.widget);
 387
 388   (* Force a repaint of the drawing area. *)
 389   let drawing_area_repaint () =
 390     GtkBase.Widget.queue_draw da#as_widget
 391   in
 392
 393   (* Pango contexts used to draw large and small text. *)
 394   let pango_large_context = da#misc#create_pango_context in
 395   pango_large_context#set_font_description (Pango.Font.from_string "Sans 12");
 396   let pango_small_context = da#misc#create_pango_context in
 397   pango_small_context#set_font_description (Pango.Font.from_string "Sans 8");
 398
 399   (* This is the currently open package, or None if nothing has
 400    * opened by the user yet.
 401    *)
 402   let opened = ref None in
 403
 404   (* If we are moused-over a particular package, then this is != None. *)
 405   let current = ref None in
 406   let set_current new_current =
 407     let old_current = !current in
 408     current := new_current;
 409     (* Because this structure contains loops, we can't use
 410      * structural comparisons like: = <> compare.
 411      *)
 412     let do_repaint =
 413       match old_current, new_current with
 414       | None, Some _ -> true
 415       | Some _, None -> true
 416       | Some { pkg = { nevra = n1 } }, Some { pkg = { nevra = n2 } } ->
 417           n1 <> n2
 418       | _ -> false in
 419     if do_repaint then drawing_area_repaint ()
 420   in
 421
 422   (* Called from the "Open package" menu entry and other places. *)
 423   let open_package pkgstr =
 424     debug "open_package %s\n%!" pkgstr;
 425
 426     (* XXX Can't be bothered to do this "properly" (ie with threads etc)
 427      * so just put a loading message in the middle of the drawing area.
 428      *)
 429     let width, height = draw#size in
 430     let txt = pango_large_context#create_layout in
 431     Pango.Layout.set_text txt (sprintf "Loading %s ..." pkgstr);
 432     let { Pango.width = txtwidth; Pango.height = txtheight } =
 433       Pango.Layout.get_pixel_extent txt in
 434     let x = (width - txtwidth) / 2 and y = (height - txtheight) / 2 in
 435     draw#set_foreground (`RGB (0, 0, 65535));
 436     draw#rectangle ~x:(x-4) ~y:(y-2)
 437       ~width:(txtwidth+8) ~height:(txtheight+8) ~filled:true ();
 438     draw#put_layout ~x ~y ~fore:`WHITE txt;
 439
 440     defer (
 441       fun () ->
 442         let root, pkgs = repoquery pkgstr in
 443         debug_pkgs root pkgs;
 444         let depsmap = create_deps pkgs in
 445         debug_deps root depsmap;
 446         let totalsmap = create_totals pkgs depsmap in
 447         let tree, depth = create_tree root depsmap totalsmap in
 448         debug_tree tree;
 449
 450         (* top_total is the total size in bytes of everything.  Used for
 451          * relative display of percentages, widths, etc.
 452          *)
 453         let Tree (_, top_total, top_increm, _, _) = tree in
 454         assert (top_total = top_increm);
 455
 456         opened :=
 457           Some (root, pkgs, depsmap, totalsmap, tree, depth, top_total);
 458         set_current None;
 459
 460         (* Update the window title. *)
 461         window#set_title (pkgstr ^ " - " ^ base_title);
 462
 463         drawing_area_repaint ()
 464     )
 465   in
 466
 467   (* If the user selected something on the command line (pkgstr !=
 468    * None) then set up an idle event to populate 'opened' as soon as
 469    * the window gets drawn on the screen.
 470    *)
 471   (match pkgstr with
 472    | None -> ()
 473    | Some pkgstr ->
 474        defer ~ms:50 (fun () -> open_package pkgstr)
 475   );
 476
 477   let callback _ =
 478     let dlg =
 479       GWindow.dialog ~parent:window ~modal:true
 480         ~position:`CENTER_ON_PARENT ~title:"Open package" () in
 481     dlg#add_button "Open package" `OPEN;
 482     dlg#add_button "Cancel" `CANCEL;
 483     let vbox = dlg#vbox in
 484     let hbox = GPack.hbox ~packing:vbox#pack () in
 485     ignore (GMisc.label ~text:"Package:" ~packing:hbox#pack ());
 486     let entry = GEdit.entry
 487       ~width_chars:40 ~packing:(hbox#pack ~expand:true ~fill:true) () in
 488     ignore (GMisc.label ~text:"Enter a package name, wildcard or path."
 489               ~packing:vbox#pack ());
 490     dlg#show ();
 491     match dlg#run () with
 492     | `CANCEL | `DELETE_EVENT ->
 493         dlg#destroy ()
 494     | `OPEN ->
 495         let pkgstr = entry#text in
 496         dlg#destroy ();
 497         if pkgstr <> "" then
 498           defer (fun () -> open_package pkgstr)
 499   in
 500   ignore (open_item#connect#activate ~callback);
 501
 502   (* Need to enable these mouse events so we can do tooltips. *)
 503   GtkBase.Widget.add_events da#as_widget
 504     [`ENTER_NOTIFY; `LEAVE_NOTIFY; `POINTER_MOTION];
 505
 506   let tooltips = ref None in
 507
 508   (* To track tooltips, the 'repaint' function records the location of
 509    * each box (ie. package) in the drawing area in this private data
 510    * structure, and the 'motion' function looks them up in order to
 511    * display the right tooltip over each box.
 512    *)
 513   let add_locn, reset_locns, get_locn =
 514     let rows = ref [||] in
 515     let rowheight = ref 0. in
 516
 517     let reset_locns rowheight' depth =
 518       (* This data structure sucks because we just do a linear search
 519        * over each row when looking up the 'x'.  Should use some sort
 520        * of self-balancing tree instead.  XXX
 521        *)
 522       rows := Array.init depth (fun _ -> ref []);
 523       rowheight := rowheight'
 524     and add_locn x yi width thing =
 525       let row = (!rows).(yi) in
 526       row := ((x, x +. width), thing) :: !row
 527     and get_locn x y =
 528       let yi = int_of_float (y /. !rowheight) in
 529       if yi >= 0 && yi < Array.length !rows then (
 530         let row = !((!rows).(yi)) in
 531         try Some
 532           (snd (List.find (fun ((xlow, xhi), thing) ->
 533                              xlow <= x && x < xhi)
 534                   row))
 535         with Not_found -> None
 536       )
 537       else None
 538     in
 539     add_locn, reset_locns, get_locn
 540   in
 541
 542   let rec real_repaint root pkgs depsmap totalsmap tree depth top_total =
 543     (* Get the canvas size and fill the background with white. *)
 544     let width, height = draw#size in
 545     draw#set_background `WHITE;
 546     draw#set_foreground `WHITE;
 547     draw#rectangle ~x:0 ~y:0 ~width ~height ~filled:true ();
 548
 549     (* Calculate the scales so we can fit everything into the window. *)
 550     let rowheight = float height /. float depth in
 551     let scale = float width /. Int64.to_float top_total in
 552
 553     reset_locns rowheight depth;
 554
 555     (* Now draw the tree. *)
 556     let rec draw_tree x yi = function
 557       | Tree (pkg, total, increm, colour, children) ->
 558           (* Draw pkg at (x, y). *)
 559           let y = float yi *. rowheight in
 560           let width = scale *. Int64.to_float increm in
 561           let pkgsizewidth = scale *. Int64.to_float pkg.size in
 562           draw_pkg x yi y width pkgsizewidth rowheight colour pkg total increm;
 563
 564           (* Draw the children of pkg at (i, y + rowheight), where
 565            * i starts as x and increments for each child.
 566            *)
 567           let yi = yi + 1 in
 568           let rec loop x = function
 569             | [] -> ()
 570             | child :: children ->
 571                 draw_tree x yi child;
 572                 let Tree (_, _, increm, _, _) = child in
 573                 let childwidth = scale *. Int64.to_float increm in
 574                 loop (x +. childwidth) children
 575           in
 576           loop x children
 577
 578     (* Draw a single package. *)
 579     and draw_pkg x yi y width pkgsizewidth height colour pkg total increm =
 580       add_locn x yi width (colour, pkg, total, increm);
 581
 582       let x = int_of_float x in
 583       let y = int_of_float y in
 584       let width = int_of_float width in
 585       let pkgsizewidth = int_of_float pkgsizewidth in
 586       let height = int_of_float height in
 587
 588       if width > 8 then (
 589         draw_pkg_outline x y width pkgsizewidth height colour pkg;
 590         draw_pkg_label x y width height colour pkg total increm
 591       )
 592       else if width >= 4 then
 593         draw_pkg_narrow x y width height colour pkg
 594           (* else
 595              XXX This doesn't work.  We need to coalesce small packages
 596              in the tree.
 597              draw_pkg_narrow x y 1 height colour *)
 598
 599     and draw_pkg_outline x y width pkgsizewidth height colour pkg =
 600       let body_colour = choose_colour colour pkg in
 601       draw#set_foreground body_colour;
 602       draw#rectangle ~x:(x+2) ~y:(y+2)
 603         ~width:(width-4) ~height:(height-4)
 604         ~filled:true ();
 605       if pkgsizewidth > 2 then (
 606         draw#set_foreground (darken body_colour);
 607         draw#rectangle ~x:(x+2) ~y:(y+2)
 608           ~width:(pkgsizewidth-2) ~height:(height-4)
 609           ~filled:true ();
 610         draw#set_foreground (choose_contrasting_colour body_colour);
 611         draw#set_line_attributes ~style:`ON_OFF_DASH ();
 612         draw#line (x+pkgsizewidth) (y+2) (x+pkgsizewidth) (y+height-2);
 613         draw#set_line_attributes ~style:`SOLID ()
 614       );
 615       draw#set_foreground `BLACK;
 616       draw#rectangle ~x:(x+2) ~y:(y+2)
 617         ~width:(width-4) ~height:(height-4)
 618         ~filled:false ()
 619
 620     and draw_pkg_label x y width height colour pkg total increm =
 621       (* How to write text in a drawing area, in case it's not
 622        * obvious, which it certainly is not:
 623        * http://www.math.nagoya-u.ac.jp/~garrigue/soft/olabl/lablgtk-list/120.txt
 624        *)
 625       (* txt1 is the same as the tooltip. *)
 626       let txt1 = lazy (
 627         let txt = pango_large_context#create_layout in
 628         Pango.Layout.set_text txt (
 629           sprintf "%s
 630 Package: %.1f%% %s (%Ld bytes)
 631 Incremental: %.1f%% %s (%Ld bytes)
 632 Total: %.1f%% %s (%Ld bytes)" pkg.nevra
 633             (display_percent pkg.size top_total) (display_size pkg.size) pkg.size
 634             (display_percent increm top_total) (display_size increm) increm
 635             (display_percent total top_total) (display_size total) total
 636         );
 637         txt
 638       )
 639       and txt2 = lazy (
 640         let txt = pango_small_context#create_layout in
 641         Pango.Layout.set_text txt (
 642           sprintf "%s
 643 Package: %.1f%% %s (%Ld bytes)
 644 Incremental: %.1f%% %s (%Ld bytes)
 645 Total: %.1f%% %s (%Ld bytes)" pkg.nevra
 646             (display_percent pkg.size top_total) (display_size pkg.size) pkg.size
 647             (display_percent increm top_total) (display_size increm) increm
 648             (display_percent total top_total) (display_size total) total
 649         );
 650         txt
 651       )
 652       and txt3 = lazy (
 653         let txt = pango_small_context#create_layout in
 654         Pango.Layout.set_text txt (
 655           sprintf "%s
 656 Pkg: %.1f%% %s (%Ld bytes)
 657 Incr: %.1f%% %s (%Ld bytes)
 658 Tot: %.1f%% %s (%Ld bytes)" pkg.name
 659             (display_percent pkg.size top_total) (display_size pkg.size) pkg.size
 660             (display_percent increm top_total) (display_size increm) increm
 661             (display_percent total top_total) (display_size total) total
 662         );
 663         txt
 664       )
 665       and txt4 = lazy (
 666         let txt = pango_small_context#create_layout in
 667         Pango.Layout.set_text txt (
 668           sprintf "%s
 669 Pkg: %.1f%% %s
 670 Incr: %.1f%% %s
 671 Tot: %.1f%% %s" pkg.name
 672             (display_percent pkg.size top_total) (display_size pkg.size)
 673             (display_percent increm top_total) (display_size increm)
 674             (display_percent total top_total) (display_size total)
 675         );
 676         txt
 677       )
 678       and txt5 = lazy (
 679         let txt = pango_small_context#create_layout in
 680         Pango.Layout.set_text txt (
 681           sprintf "%s\nPkg: %.1f%%\nIncr: %.1f%%\nTot: %.1f%%"
 682             pkg.name
 683             (display_percent pkg.size top_total)
 684             (display_percent increm top_total)
 685             (display_percent total top_total)
 686         );
 687         txt
 688       )
 689       and txt6 = lazy (
 690         let txt = pango_small_context#create_layout in
 691         Pango.Layout.set_text txt (
 692           sprintf "%s Pkg: %.1f%% %s Incr: %.1f%% %s Tot: %.1f%% %s" pkg.name
 693             (display_percent pkg.size top_total) (display_size pkg.size)
 694             (display_percent increm top_total) (display_size increm)
 695             (display_percent total top_total) (display_size total)
 696         );
 697         txt
 698       )
 699       and txt7 = lazy (
 700         let txt = pango_small_context#create_layout in
 701         Pango.Layout.set_text txt (
 702           sprintf "%s %.1f%% %.1f%% %.1f%%" pkg.name
 703             (display_percent pkg.size top_total)
 704             (display_percent increm top_total)
 705             (display_percent total top_total)
 706         );
 707         txt
 708       )
 709       and txt8 = lazy (
 710         let txt = pango_small_context#create_layout in
 711         Pango.Layout.set_text txt (
 712           sprintf "%s" pkg.name
 713         );
 714         txt
 715       ) in
 716       let txts = [ txt1; txt2; txt3; txt4; txt5; txt6; txt7; txt8 ] in
 717
 718       let fore = choose_contrasting_colour colour in
 719
 720       let rec loop = function
 721         | [] -> ()
 722         | txt :: txts ->
 723             let txt = Lazy.force txt in
 724             let { Pango.width = txtwidth;
 725                   Pango.height = txtheight } =
 726               Pango.Layout.get_pixel_extent txt in
 727             (* Now with added fudge-factor. *)
 728             if width >= txtwidth + 8 && height >= txtheight + 8 then
 729               draw#put_layout ~x:(x+4) ~y:(y+4) ~fore txt
 730             else loop txts
 731       in
 732       loop txts
 733
 734     and draw_pkg_narrow x y width height colour pkg =
 735       draw#set_foreground (choose_colour colour pkg);
 736       draw#rectangle ~x:(x+2) ~y:(y+2)
 737         ~width:(width-4) ~height:(height-4) ~filled:true ()
 738
 739     and choose_contrasting_colour = function
 740       | `RGB (r, g, b) ->
 741           if r + g + b > 98304 then `BLACK else `WHITE
 742       | _ -> `WHITE
 743
 744     and choose_colour colour pkg =
 745       match !current with
 746       | None -> colour
 747       | Some current ->
 748           let nevra = pkg.nevra in
 749           let is_parent =
 750             List.exists
 751               (fun { pkg = { nevra = n } } -> n = nevra) current.parents in
 752           let is_child =
 753             List.exists
 754               (fun { pkg = { nevra = n } } -> n = nevra) current.children in
 755           if is_parent && is_child then `RGB (63000, 63000, 0) (* yellow *)
 756           else if is_parent then `RGB (0, 63000, 63000) (* cyan *)
 757           else if is_child then `RGB (0, 63000, 0) (* green *)
 758           else colour
 759
 760     and darken = function
 761       | `RGB (r, g, b) ->
 762           `RGB (r * 9 / 10, g * 9 / 10, b * 9 / 10)
 763       | _ -> `WHITE
 764     in
 765     draw_tree 0. 0 tree
 766
 767   and repaint _ =
 768     (match !opened with
 769      | None -> ()
 770      | Some (root, pkgs, depsmap, totalsmap, tree, depth, top_total) ->
 771          real_repaint root pkgs depsmap totalsmap tree depth top_total
 772     );
 773
 774     (* Return false because this is a Gtk event handler. *)
 775     false
 776   in
 777   ignore (da#event#connect#expose ~callback:repaint);
 778
 779   let rec real_motion root pkgs depsmap totalsmap tree depth top_total ev =
 780     let x, y = GdkEvent.Motion.x ev, GdkEvent.Motion.y ev in
 781
 782     let kill_tooltip () =
 783       (match !tooltips with
 784        | None -> ()
 785        | Some (tt : GData.tooltips) ->
 786            tt#set_tip ~text:"" (da :> GObj.widget);
 787            tt#disable ()
 788       );
 789       tooltips := None
 790     in
 791
 792     (match get_locn x y with
 793      | None ->
 794          set_current None;
 795          kill_tooltip ()
 796      | Some (colour, pkg, total, increm) ->
 797          (* Update 'current' which points to the currently moused package. *)
 798          let dep = StringMap.find pkg.nevra depsmap in
 799          set_current (Some dep);
 800
 801          let deps_of_string deps =
 802            String.concat "\n  "
 803              (List.sort (List.map (fun d -> d.pkg.nevra) deps))
 804          in
 805
 806          (* The only way to make the tooltip follow the mouse is to
 807           * kill the whole tooltips object and recreate it each time ...
 808           *)
 809          kill_tooltip ();
 810          let tt = GData.tooltips ~delay:100 () in
 811          (* Tooltip text is the same as txt1 + extra. *)
 812          let text = sprintf "%s
 813 Package: %.1f%% %s (%Ld bytes)
 814 Incremental: %.1f%% %s (%Ld bytes)
 815 Total: %.1f%% %s (%Ld bytes)" pkg.nevra
 816            (display_percent pkg.size top_total) (display_size pkg.size) pkg.size
 817            (display_percent increm top_total) (display_size increm) increm
 818            (display_percent total top_total) (display_size total) total in
 819          let text = if dep.parents = [] then text else text ^ sprintf "
 820 Required by (blue):
 821   %s"
 822            (deps_of_string dep.parents) in
 823          let text = if dep.children = [] then text else text ^ sprintf "
 824 Requires (green):
 825   %s"
 826            (deps_of_string dep.children) in
 827          tt#set_tip ~text (da :> GObj.widget);
 828          tt#enable ();
 829          tooltips := Some tt
 830     )
 831
 832   and motion ev =
 833     (match !opened with
 834      | None -> ()
 835      | Some (root, pkgs, depsmap, totalsmap, tree, depth, top_total) ->
 836          real_motion root pkgs depsmap totalsmap tree depth top_total ev
 837     );
 838
 839     (* Return false because this is a Gtk event handler. *)
 840     false
 841   in
 842   ignore (da#event#connect#motion_notify ~callback:motion);
 843
 844   window#add_accel_group accel_group;
 845   window#show ();
 846   GMain.main ()
 847
 848 (* Main program. *)
 849 let () =
 850   (* Parse the command line arguments. *)
 851   let anon_args = ref [] in
 852
 853   let argspec = Arg.align [
 854     "--debug", Arg.Set debug_flag,
 855     " " ^ "Enable debugging messages on stderr";
 856   ] in
 857   let anon_fun str = anon_args := str :: !anon_args in
 858   let usage_msg =
 859     "rpmdepsize [package] : visualize the size of RPM dependencies" in
 860
 861   Arg.parse argspec anon_fun usage_msg;
 862
 863   (* Should be at most one anonymous argument. *)
 864   let pkgstr =
 865     match !anon_args with
 866     | [] -> None
 867     | [p] -> Some p
 868     | _ ->
 869         eprintf "rpmdepsize: too many command line arguments";
 870         exit 1 in
 871
 872   (* Open the main window. *)
 873   open_window pkgstr