* Python script modified from a version by Seth Vidal.
*)
+(* Rename the extlib Std module so it doesn't clash with the
+ * sexplib Std module.
+ *)
+module Extlib_Std = Std
+
open Sexplib
-TYPE_CONV_PATH "."
+open Sexplib.Conv
+(*TYPE_CONV_PATH "."*)
open ExtList
open Unix
let chan = open_process_in cmd in
ignore (input_line chan); (* Drop "Loaded plugins" line. *)
let root, pkgs =
- root_packages_of_sexp (Sexp.of_string (Std.input_all chan)) in
+ root_packages_of_sexp (Sexp.of_string (Extlib_Std.input_all chan)) in
(match close_process_in chan with
| WEXITED 0 -> ()
| WEXITED i -> failwithf "python command exited with status %d" i
window#set_geometry_hints ~min_size:(80,80) (da :> GObj.widget);
+ (* Force a repaint of the drawing area. *)
+ let drawing_area_repaint () =
+ GtkBase.Widget.queue_draw da#as_widget
+ in
+
(* Pango contexts used to draw large and small text. *)
let pango_large_context = da#misc#create_pango_context in
pango_large_context#set_font_description (Pango.Font.from_string "Sans 12");
*)
let opened = ref None in
+ (* If we are moused-over a particular package, then this is != None. *)
+ let current = ref None in
+ let set_current new_current =
+ let old_current = !current in
+ current := new_current;
+ (* Because this structure contains loops, we can't use
+ * structural comparisons like: = <> compare.
+ *)
+ let do_repaint =
+ match old_current, new_current with
+ | None, Some _ -> true
+ | Some _, None -> true
+ | Some { pkg = { nevra = n1 } }, Some { pkg = { nevra = n2 } } ->
+ n1 <> n2
+ | _ -> false in
+ if do_repaint then drawing_area_repaint ()
+ in
+
(* Called from the "Open package" menu entry and other places. *)
let open_package pkgstr =
debug "open_package %s\n%!" pkgstr;
opened :=
Some (root, pkgs, depsmap, totalsmap, tree, depth, top_total);
+ set_current None;
(* Update the window title. *)
window#set_title (pkgstr ^ " - " ^ base_title);
- (* Force a repaint of the drawing area. *)
- GtkBase.Widget.queue_draw da#as_widget;
+ drawing_area_repaint ()
)
in
let height = int_of_float height in
if width > 8 then (
- draw_pkg_outline x y width pkgsizewidth height colour;
+ draw_pkg_outline x y width pkgsizewidth height colour pkg;
draw_pkg_label x y width height colour pkg total increm
)
else if width >= 4 then
- draw_pkg_narrow x y width height colour
+ draw_pkg_narrow x y width height colour pkg
(* 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;
+ and draw_pkg_outline x y width pkgsizewidth height colour pkg =
+ let body_colour = choose_colour colour pkg in
+ draw#set_foreground body_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#set_foreground (darken body_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_foreground (choose_contrasting_colour body_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#set_foreground `BLACK;
draw#rectangle ~x:(x+2) ~y:(y+2)
~width:(width-4) ~height:(height-4)
~filled:false ()
in
loop txts
- and draw_pkg_narrow x y width height colour =
- draw#set_foreground colour;
+ and draw_pkg_narrow x y width height colour pkg =
+ draw#set_foreground (choose_colour colour pkg);
draw#rectangle ~x:(x+2) ~y:(y+2)
~width:(width-4) ~height:(height-4) ~filled:true ()
if r + g + b > 98304 then `BLACK else `WHITE
| _ -> `WHITE
+ and choose_colour colour pkg =
+ match !current with
+ | None -> colour
+ | Some current ->
+ let nevra = pkg.nevra in
+ let is_parent =
+ List.exists
+ (fun { pkg = { nevra = n } } -> n = nevra) current.parents in
+ let is_child =
+ List.exists
+ (fun { pkg = { nevra = n } } -> n = nevra) current.children in
+ if is_parent && is_child then `RGB (63000, 63000, 0) (* yellow *)
+ else if is_parent then `RGB (0, 63000, 63000) (* cyan *)
+ else if is_child then `RGB (0, 63000, 0) (* green *)
+ else colour
+
and darken = function
| `RGB (r, g, b) ->
`RGB (r * 9 / 10, g * 9 / 10, b * 9 / 10)
(match get_locn x y with
| None ->
+ set_current None;
kill_tooltip ()
| Some (colour, pkg, total, increm) ->
+ (* Update 'current' which points to the currently moused package. *)
+ let dep = StringMap.find pkg.nevra depsmap in
+ set_current (Some dep);
+
+ let deps_of_string deps =
+ String.concat "\n "
+ (List.sort (List.map (fun d -> d.pkg.nevra) deps))
+ in
+
(* 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. *)
+ (* Tooltip text is the same as txt1 + extra. *)
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
+ (display_percent increm top_total) (display_size increm) increm
+ (display_percent total top_total) (display_size total) total in
+ let text = if dep.parents = [] then text else text ^ sprintf "
+Required by (blue):
+ %s"
+ (deps_of_string dep.parents) in
+ let text = if dep.children = [] then text else text ^ sprintf "
+Requires (green):
+ %s"
+ (deps_of_string dep.children) in
tt#set_tip ~text (da :> GObj.widget);
tt#enable ();
tooltips := Some tt
git.annexia.org / rpmdepsize.git / blobdiff