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