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