+
+ let rec real_repaint root pkgs depsmap totalsmap tree depth top_total =
+ (* Get the canvas size and fill the background with white. *)
+ let width, height = draw#size in
+ draw#set_background `WHITE;
+ draw#set_foreground `WHITE;
+ draw#rectangle ~x:0 ~y:0 ~width ~height ~filled:true ();
+
+ (* Calculate the scales so we can fit everything into the window. *)
+ let rowheight = float height /. float depth in
+ let scale = float width /. Int64.to_float top_total in
+
+ reset_locns rowheight depth;
+
+ (* Now draw the tree. *)
+ let rec draw_tree x yi = function
+ | Tree (pkg, total, increm, colour, children) ->
+ (* Draw pkg at (x, y). *)
+ let y = float yi *. rowheight in
+ let width = scale *. Int64.to_float increm in
+ let pkgsizewidth = scale *. Int64.to_float pkg.size in
+ draw_pkg x yi y width pkgsizewidth rowheight colour pkg total increm;
+
+ (* Draw the children of pkg at (i, y + rowheight), where
+ * i starts as x and increments for each child.
+ *)
+ let yi = yi + 1 in
+ let rec loop x = function
+ | [] -> ()
+ | child :: children ->
+ draw_tree x yi child;
+ let Tree (_, _, increm, _, _) = child in
+ let childwidth = scale *. Int64.to_float increm in
+ loop (x +. childwidth) children
+ in
+ loop x children
+
+ (* Draw a single package. *)
+ and draw_pkg x yi y width pkgsizewidth height colour pkg total increm =
+ add_locn x yi width (colour, pkg, total, increm);
+
+ let x = int_of_float x in
+ let y = int_of_float y in
+ let width = int_of_float width in
+ let pkgsizewidth = int_of_float pkgsizewidth in
+ let height = int_of_float height in
+
+ if width > 8 then (
+ draw_pkg_outline x y width pkgsizewidth height colour;
+ draw_pkg_label x y width height colour pkg total increm
+ )
+ else if width >= 4 then
+ draw_pkg_narrow x y width height colour
+ (* else
+ XXX This doesn't work. We need to coalesce small packages
+ in the tree.
+ draw_pkg_narrow x y 1 height colour *)
+
+ and draw_pkg_outline x y width pkgsizewidth height colour =
+ draw#set_foreground colour;
+ draw#rectangle ~x:(x+2) ~y:(y+2)
+ ~width:(width-4) ~height:(height-4)
+ ~filled:true ();
+ if pkgsizewidth > 2 then (
+ draw#set_foreground (darken colour);
+ draw#rectangle ~x:(x+2) ~y:(y+2)
+ ~width:(pkgsizewidth-2) ~height:(height-4)
+ ~filled:true ();
+ draw#set_foreground (choose_contrasting_colour colour);
+ draw#set_line_attributes ~style:`ON_OFF_DASH ();
+ draw#line (x+pkgsizewidth) (y+2) (x+pkgsizewidth) (y+height-2);
+ draw#set_line_attributes ~style:`SOLID ()
+ );
+ draw#set_foreground (`BLACK);
+ draw#rectangle ~x:(x+2) ~y:(y+2)
+ ~width:(width-4) ~height:(height-4)
+ ~filled:false ()
+
+ and draw_pkg_label x y width height colour pkg total increm =
+ (* How to write text in a drawing area, in case it's not
+ * obvious, which it certainly is not:
+ * http://www.math.nagoya-u.ac.jp/~garrigue/soft/olabl/lablgtk-list/120.txt
+ *)
+ (* txt1 is the same as the tooltip. *)
+ let txt1 = lazy (
+ let txt = pango_large_context#create_layout in
+ Pango.Layout.set_text txt (
+ sprintf "%s
+Package: %.1f%% %s (%Ld bytes)
+Incremental: %.1f%% %s (%Ld bytes)
+Total: %.1f%% %s (%Ld bytes)" pkg.nevra
+ (display_percent pkg.size top_total) (display_size pkg.size) pkg.size
+ (display_percent increm top_total) (display_size increm) increm
+ (display_percent total top_total) (display_size total) total
+ );
+ txt
+ )
+ and txt2 = lazy (
+ let txt = pango_small_context#create_layout in
+ Pango.Layout.set_text txt (
+ sprintf "%s
+Package: %.1f%% %s (%Ld bytes)
+Incremental: %.1f%% %s (%Ld bytes)
+Total: %.1f%% %s (%Ld bytes)" pkg.nevra
+ (display_percent pkg.size top_total) (display_size pkg.size) pkg.size
+ (display_percent increm top_total) (display_size increm) increm
+ (display_percent total top_total) (display_size total) total
+ );
+ txt
+ )
+ and txt3 = lazy (
+ let txt = pango_small_context#create_layout in
+ Pango.Layout.set_text txt (
+ sprintf "%s
+Pkg: %.1f%% %s (%Ld bytes)
+Incr: %.1f%% %s (%Ld bytes)
+Tot: %.1f%% %s (%Ld bytes)" pkg.name
+ (display_percent pkg.size top_total) (display_size pkg.size) pkg.size
+ (display_percent increm top_total) (display_size increm) increm
+ (display_percent total top_total) (display_size total) total
+ );
+ txt
+ )
+ and txt4 = lazy (
+ let txt = pango_small_context#create_layout in
+ Pango.Layout.set_text txt (
+ sprintf "%s
+Pkg: %.1f%% %s
+Incr: %.1f%% %s
+Tot: %.1f%% %s" pkg.name
+ (display_percent pkg.size top_total) (display_size pkg.size)
+ (display_percent increm top_total) (display_size increm)
+ (display_percent total top_total) (display_size total)
+ );
+ txt
+ )
+ and txt5 = lazy (
+ let txt = pango_small_context#create_layout in
+ Pango.Layout.set_text txt (
+ sprintf "%s\nPkg: %.1f%%\nIncr: %.1f%%\nTot: %.1f%%"
+ pkg.name
+ (display_percent pkg.size top_total)
+ (display_percent increm top_total)
+ (display_percent total top_total)
+ );
+ txt
+ )
+ and txt6 = lazy (
+ let txt = pango_small_context#create_layout in
+ Pango.Layout.set_text txt (
+ sprintf "%s Pkg: %.1f%% %s Incr: %.1f%% %s Tot: %.1f%% %s" pkg.name
+ (display_percent pkg.size top_total) (display_size pkg.size)
+ (display_percent increm top_total) (display_size increm)
+ (display_percent total top_total) (display_size total)
+ );
+ txt
+ )
+ and txt7 = lazy (
+ let txt = pango_small_context#create_layout in
+ Pango.Layout.set_text txt (
+ sprintf "%s %.1f%% %.1f%% %.1f%%" pkg.name
+ (display_percent pkg.size top_total)
+ (display_percent increm top_total)
+ (display_percent total top_total)
+ );
+ txt
+ )
+ and txt8 = lazy (
+ let txt = pango_small_context#create_layout in
+ Pango.Layout.set_text txt (
+ sprintf "%s" pkg.name
+ );
+ txt
+ ) in
+ let txts = [ txt1; txt2; txt3; txt4; txt5; txt6; txt7; txt8 ] in
+
+ let fore = choose_contrasting_colour colour in
+
+ let rec loop = function
+ | [] -> ()
+ | txt :: txts ->
+ let txt = Lazy.force txt in
+ let { Pango.width = txtwidth;
+ Pango.height = txtheight } =
+ Pango.Layout.get_pixel_extent txt in
+ (* Now with added fudge-factor. *)
+ if width >= txtwidth + 8 && height >= txtheight + 8 then
+ draw#put_layout ~x:(x+4) ~y:(y+4) ~fore txt
+ else loop txts
+ in
+ loop txts
+
+ and draw_pkg_narrow x y width height colour =
+ draw#set_foreground colour;
+ draw#rectangle ~x:(x+2) ~y:(y+2)
+ ~width:(width-4) ~height:(height-4) ~filled:true ()
+
+ and choose_contrasting_colour = function
+ | `RGB (r, g, b) ->
+ if r + g + b > 98304 then `BLACK else `WHITE
+ | _ -> `WHITE
+
+ and darken = function
+ | `RGB (r, g, b) ->
+ `RGB (r * 9 / 10, g * 9 / 10, b * 9 / 10)
+ | _ -> `WHITE
+ in
+ draw_tree 0. 0 tree
+
+ and repaint _ =
+ (match !opened with
+ | None -> ()
+ | Some (root, pkgs, depsmap, totalsmap, tree, depth, top_total) ->
+ real_repaint root pkgs depsmap totalsmap tree depth top_total
+ );
+
+ (* Return false because this is a Gtk event handler. *)
+ false
+ in
+ ignore (da#event#connect#expose ~callback:repaint);
+
+ let rec real_motion root pkgs depsmap totalsmap tree depth top_total ev =
+ let x, y = GdkEvent.Motion.x ev, GdkEvent.Motion.y ev in
+
+ let kill_tooltip () =
+ (match !tooltips with
+ | None -> ()
+ | Some (tt : GData.tooltips) ->
+ tt#set_tip ~text:"" (da :> GObj.widget);
+ tt#disable ()
+ );
+ tooltips := None
+ in
+
+ (match get_locn x y with
+ | None ->
+ kill_tooltip ()
+ | Some (colour, pkg, total, increm) ->
+ (* The only way to make the tooltip follow the mouse is to
+ * kill the whole tooltips object and recreate it each time ...
+ *)
+ kill_tooltip ();
+ let tt = GData.tooltips ~delay:100 () in
+ (* Tooltip text is the same as txt1. *)
+ let text = sprintf "%s
+Package: %.1f%% %s (%Ld bytes)
+Incremental: %.1f%% %s (%Ld bytes)
+Total: %.1f%% %s (%Ld bytes)" pkg.nevra
+ (display_percent pkg.size top_total) (display_size pkg.size) pkg.size
+(display_percent increm top_total) (display_size increm) increm
+(display_percent total top_total) (display_size total) total in
+ tt#set_tip ~text (da :> GObj.widget);
+ tt#enable ();
+ tooltips := Some tt
+ )
+
+ and motion ev =
+ (match !opened with
+ | None -> ()
+ | Some (root, pkgs, depsmap, totalsmap, tree, depth, top_total) ->
+ real_motion root pkgs depsmap totalsmap tree depth top_total ev
+ );
+
+ (* Return false because this is a Gtk event handler. *)
+ false
+ in
+ ignore (da#event#connect#motion_notify ~callback:motion);
+
+ window#add_accel_group accel_group;
+ window#show ();
+ GMain.main ()
+
+(* Main program. *)
+let () =
+ (* Parse the command line arguments. *)
+ let anon_args = ref [] in
+
+ let argspec = Arg.align [
+ "--debug", Arg.Set debug_flag,
+ " " ^ "Enable debugging messages on stderr";
+ ] in
+ let anon_fun str = anon_args := str :: !anon_args in
+ let usage_msg =
+ "rpmdepsize [package] : visualize the size of RPM dependencies" in
+
+ Arg.parse argspec anon_fun usage_msg;
+
+ (* Should be at most one anonymous argument. *)
+ let pkgstr =
+ match !anon_args with
+ | [] -> None
+ | [p] -> Some p
+ | _ ->
+ eprintf "rpmdepsize: too many command line arguments";
+ exit 1 in
+
+ (* Open the main window. *)
+ open_window pkgstr