From: rjones Date: Fri, 27 Mar 2009 12:15:42 +0000 (+0000) Subject: Restructured, added menus. X-Git-Url: http://git.annexia.org/?p=rpmdepsize.git;a=commitdiff_plain;h=b457fcbcf8684adbb8a8b8e26ff0ad231a684a3a Restructured, added menus. --- diff --git a/.cvsignore b/.cvsignore index 1160787..785c92a 100644 --- a/.cvsignore +++ b/.cvsignore @@ -12,4 +12,5 @@ config.log config.status configure rpmdepsize +rpmdepsize_about.ml stamp-h1 diff --git a/Makefile.am b/Makefile.am index fcf298c..27ab0c2 100644 --- a/Makefile.am +++ b/Makefile.am @@ -19,16 +19,18 @@ ACLOCAL_AMFLAGS = -I m4 -EXTRA_DIST = rpmdepsize.ml +MLFILES = rpmdepsize_about.ml rpmdepsize_errors.ml rpmdepsize.ml + +EXTRA_DIST = $(MLFILES) rpmdepsize_about.ml.in CLEANFILES = rpmdepsize bin_SCRIPTS = rpmdepsize -rpmdepsize: rpmdepsize.ml +rpmdepsize: $(MLFILES) $(OCAMLFIND) $(OCAMLBEST) \ -package lablgtk2,sexplib,unix,extlib,sexplib.syntax \ -syntax camlp4o \ -linkpkg \ gtkInit.cmx \ - $< -o $@ + $^ -o $@ diff --git a/configure.ac b/configure.ac index 7e761f2..d171b9d 100644 --- a/configure.ac +++ b/configure.ac @@ -55,5 +55,5 @@ if test "x$YUM" = "xno" ; then fi AC_CONFIG_HEADERS([config.h]) -AC_CONFIG_FILES([Makefile]) +AC_CONFIG_FILES([Makefile rpmdepsize_about.ml]) AC_OUTPUT diff --git a/rpmdepsize.ml b/rpmdepsize.ml index 1fb9458..47df458 100644 --- a/rpmdepsize.ml +++ b/rpmdepsize.ml @@ -26,8 +26,6 @@ open ExtList open Unix open Printf -let debug = true - (* This corresponds to the sexpr that we write out from the * Python code. OCaml will type-check it. *) @@ -56,17 +54,30 @@ type deps = Deps of pkg * deps list ref *) type tree = Tree of pkg * int64 * int64 * GDraw.color * tree list +(* Helpful modules, operators and functions. *) module StringMap = Map.Make (String) let (+^) = Int64.add let sum = List.fold_left (+^) 0L let spaces n = String.make n ' ' +let failwithf = ksprintf failwith + +(* Debugging support (--debug on the command line). *) +let debug_flag = ref false +let debug format = + (* ifprintf consumes the arguments, but produces no output *) + (if !debug_flag then eprintf else ifprintf Pervasives.stderr) format (* Python has privileged access to the yum repodata, so we have to use * this Python snippet to pull the data that we need out. This is the * part of the program that takes ages to run, because Python is as - * slow as a fat snake that's just eaten a huge lunch. We can't help that. + * slow as a fat snake that's just eaten a huge lunch. We can't help + * that. + * + * This function takes a string (package name) and returns a + * root_packages type. *) -let repoquery_py = " +let repoquery pkgstr = + let py = " import yum import yum.misc import sys @@ -102,35 +113,31 @@ for pkg in deps.keys(): for p in deps[pkg]: print \"%s \" % p, print \")))\" -sys.stdout.write (\"))\") # suppress trailing newline" - -let () = - printf "getting repository information (this can take a few seconds ...)\n%!"; +sys.stdout.write (\"))\") # suppress trailing newline" in (* Run the Python program and read in the generated sexpr. *) let cmd = - sprintf "python -c %s %s" - (Filename.quote repoquery_py) (Filename.quote Sys.argv.(1)) in + sprintf "python -c %s %s" (Filename.quote py) (Filename.quote pkgstr) in let chan = open_process_in cmd in - ignore (input_line chan); (* drop "Loaded plugins" *) + ignore (input_line chan); (* Drop "Loaded plugins" line. *) let root, pkgs = root_packages_of_sexp (Sexp.of_string (Std.input_all chan)) in (match close_process_in chan with | WEXITED 0 -> () - | WEXITED i -> failwith (sprintf "command exited with status %d" i) + | WEXITED i -> failwithf "python command exited with status %d" i | WSIGNALED i | WSTOPPED i -> - failwith (sprintf "command stopped with signal %d" i) + failwithf "python command stopped with signal %d" i ); - if debug then ( - List.iter ( - fun pkg -> printf "%s -> [%s]\n" pkg.nevra (String.concat ", " pkg.deps) - ) pkgs; - printf "root package is %s\n" root; - printf "===\n%!" - ); + (root, pkgs) - (* Create the dependency graph, probably contains loops so beware. *) +(* Create the dependency graph from the raw package data. Probably + * contains loops so beware. + * + * Takes the list of packages (from Python code) and returns a + * StringMap of nevra -> deps. + *) +let create_deps pkgs = let deps = List.map (fun pkg -> Deps (pkg, ref [])) pkgs in let depsmap = List.fold_left ( @@ -142,32 +149,16 @@ let () = let deps' = List.map (fun n -> StringMap.find n depsmap) pkg.deps in deps := List.append !deps deps' ) deps; - let deps = () in ignore deps; - - if debug then ( - let seen = ref StringMap.empty in - let rec display ?(indent=0) = function - | Deps (pkg, deps) -> - if StringMap.mem pkg.nevra !seen then - printf "%s%s -> ...\n" (spaces indent) pkg.nevra - else ( - printf "%s%s -> [%s]\n" - (spaces indent) pkg.nevra ( - String.concat ", " - (List.map (fun (Deps (pkg, _)) -> pkg.nevra) !deps) - ); - seen := StringMap.add pkg.nevra true !seen; - List.iter (display ~indent:(indent+2)) !deps - ) - in - display (StringMap.find root depsmap); - printf "===\n%!" - ); + depsmap - (* For each package, calculate the total installed size of the package, - * which includes all subpackages pulled in. So it's what would be - * installed if you did 'yum install foo'. - *) +(* For each package, calculate the total installed size of the package, + * which includes all subpackages pulled in. So it's what would be + * installed if you did 'yum install foo'. + * + * Takes the list of packages and the dependency map (see 'create_deps') + * and returns a StringMap of nevra -> total. + *) +let create_totals pkgs depsmap = let total pkg = let seen = ref StringMap.empty in let rec _total = function @@ -182,13 +173,19 @@ let () = List.fold_left ( fun map pkg -> StringMap.add pkg.nevra (total pkg) map ) StringMap.empty pkgs in + totalsmap - (* Create the final display tree. Each node is sorted so that - * children with the largest contribution come first (on the left). - * We remove packages which are already installed by earlier - * (leftward) packages. At each node we also store total size and - * size of the additional packages. - *) +(* Create the final display tree. Each node is sorted so that + * children with the largest contribution come first (on the left). + * We remove packages which are already installed by earlier + * (leftward) packages. At each node we also store total size and + * size of the additional packages. + * + * Takes the nevra of the root package, the depsmap (see 'create_deps') + * and the totalsmap (see 'create_totals'), and returns the display + * tree and the depth of the tree. + *) +let create_tree root depsmap totalsmap = let tree = let seen = StringMap.empty in let seen = StringMap.add root true seen in @@ -220,16 +217,6 @@ let () = in build_tree (StringMap.find root depsmap) in - if debug then ( - let rec display ?(indent=0) = function - | Tree (pkg, total, increm, _, children) -> - printf "%s%s %Ld/%Ld/%Ld\n%!" - (spaces indent) pkg.nevra pkg.size increm total; - List.iter (display ~indent:(indent+2)) children - in - display tree; - ); - (* Max depth of the tree. *) let depth = let rec depth = function @@ -282,36 +269,199 @@ let () = colour_level2 pcols level2 in Tree (pkg, total, increm, `RGB (55000, 55000, 55000), level2) in - (* top_total is the total size in bytes of everything. Used for - * relative display of percentages, widths, etc. - *) - let Tree (_, top_total, top_increm, _, _) = tree in - assert (top_total = top_increm); - - (* Useful display functions. *) - let display_percent bytes = - 100. *. Int64.to_float bytes /. Int64.to_float top_total - - and display_size bytes = - if bytes > 104_857L then - sprintf "%.1f MB" (Int64.to_float bytes /. 1_048_576.) - else if bytes > 102L then - sprintf "%.1f KB" (Int64.to_float bytes /. 1_024.) - else - sprintf "%Ld" bytes - in + tree, depth + +(* Debugging functions. These only produce any output if debugging + * was enabled on the command line. + *) +let debug_pkgs root pkgs = + if !debug_flag then ( + List.iter ( + fun pkg -> + eprintf "%s -> [%s]\n" pkg.nevra (String.concat ", " pkg.deps) + ) pkgs; + eprintf "root package is %s\n" root; + eprintf "===\n%!" + ) + +let debug_deps root depsmap = + if !debug_flag then ( + let seen = ref StringMap.empty in + let rec display ?(indent=0) = function + | Deps (pkg, deps) -> + if StringMap.mem pkg.nevra !seen then + eprintf "%s%s -> ...\n" (spaces indent) pkg.nevra + else ( + eprintf "%s%s -> [%s]\n" + (spaces indent) pkg.nevra ( + String.concat ", " + (List.map (fun (Deps (pkg, _)) -> pkg.nevra) !deps) + ); + seen := StringMap.add pkg.nevra true !seen; + List.iter (display ~indent:(indent+2)) !deps + ) + in + display (StringMap.find root depsmap); + eprintf "===\n%!" + ) +let debug_tree tree = + if !debug_flag then ( + let rec display ?(indent=0) = function + | Tree (pkg, total, increm, _, children) -> + eprintf "%s%s %Ld/%Ld/%Ld\n%!" + (spaces indent) pkg.nevra pkg.size increm total; + List.iter (display ~indent:(indent+2)) children + in + display tree; + ) + +(* Useful display functions. *) +let display_percent bytes top_total = + 100. *. Int64.to_float bytes /. Int64.to_float top_total + +let display_size bytes = + if bytes > 104_857L then + sprintf "%.1f MB" (Int64.to_float bytes /. 1_048_576.) + else if bytes > 102L then + sprintf "%.1f KB" (Int64.to_float bytes /. 1_024.) + else + sprintf "%Ld" bytes + +(* Defer a function callback until Gtk rendering has been done. *) +let defer ?(ms=10) f = + ignore (GMain.Timeout.add ~ms ~callback:(fun () -> f (); false)) + +(* Open the toplevel window. The 'pkgstr' parameter is the optional + * name of the package to open. If None then we open a blank window. + *) +let open_window pkgstr = (* Open the window. *) - let title = root ^ " - Fedora RPM dependency size viewer" in + let base_title = "Fedora RPM dependency size viewer" in let window = - GWindow.window ~width:800 ~height:600 ~title ~allow_shrink:true () in + GWindow.window ~width:800 ~height:600 + ~title:base_title ~allow_shrink:true () in + + let vbox = GPack.vbox ~packing:window#add () in + + (* Menu bar. *) + let menubar = GMenu.menu_bar ~packing:vbox#pack () in + let factory = new GMenu.factory menubar in + let accel_group = factory#accel_group in + let package_menu = factory#add_submenu "_Package" in + let help_menu = factory#add_submenu "_Help" in + + let factory = new GMenu.factory package_menu ~accel_group in + let open_item = factory#add_item "_Open package ..." ~key:GdkKeysyms._O in + let quit_item = factory#add_item "E_xit" ~key:GdkKeysyms._Q in + + let factory = new GMenu.factory help_menu ~accel_group in + let about_item = factory#add_item "About" in + (* Events for the menu bar. *) ignore (window#connect#destroy ~callback:GMain.quit); + ignore (quit_item#connect#activate ~callback:GMain.quit); - let da = GMisc.drawing_area ~packing:window#add () in + ignore (about_item#connect#activate ~callback:Rpmdepsize_about.callback); + + let da = GMisc.drawing_area + ~packing:(vbox#pack ~expand:true ~fill:true) () in da#misc#realize (); let draw = new GDraw.drawable da#misc#window in + window#set_geometry_hints ~min_size:(80,80) (da :> GObj.widget); + + (* 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 pango_small_context = da#misc#create_pango_context in + pango_small_context#set_font_description (Pango.Font.from_string "Sans 8"); + + (* This is the currently open package, or None if nothing has + * opened by the user yet. + *) + let current = ref None in + + (* Called from the "Open package" menu entry and other places. *) + let open_package pkgstr = + debug "open_package %s\n%!" pkgstr; + + (* XXX Can't be bothered to do this "properly" (ie with threads etc) + * so just put a loading message in the middle of the drawing area. + *) + let width, height = draw#size in + let txt = pango_large_context#create_layout in + Pango.Layout.set_text txt (sprintf "Loading %s ..." pkgstr); + let { Pango.width = txtwidth; Pango.height = txtheight } = + Pango.Layout.get_pixel_extent txt in + let x = (width - txtwidth) / 2 and y = (height - txtheight) / 2 in + draw#set_foreground (`RGB (0, 0, 65535)); + draw#rectangle ~x:(x-4) ~y:(y-2) + ~width:(txtwidth+8) ~height:(txtheight+8) ~filled:true (); + draw#put_layout ~x ~y ~fore:`WHITE txt; + + defer ( + fun () -> + let root, pkgs = repoquery pkgstr in + debug_pkgs root pkgs; + let depsmap = create_deps pkgs in + debug_deps root depsmap; + let totalsmap = create_totals pkgs depsmap in + let tree, depth = create_tree root depsmap totalsmap in + debug_tree tree; + + (* top_total is the total size in bytes of everything. Used for + * relative display of percentages, widths, etc. + *) + let Tree (_, top_total, top_increm, _, _) = tree in + assert (top_total = top_increm); + + current := + Some (root, pkgs, depsmap, totalsmap, tree, depth, top_total); + + (* Update the window title. *) + window#set_title (pkgstr ^ " - " ^ base_title); + + (* Force a repaint of the drawing area. *) + GtkBase.Widget.queue_draw da#as_widget; + ) + in + + (* If the user selected something on the command line (pkgstr != + * None) then set up an idle event to populate 'current' as soon as + * the window gets drawn on the screen. + *) + (match pkgstr with + | None -> () + | Some pkgstr -> + defer ~ms:50 (fun () -> open_package pkgstr) + ); + + let callback _ = + let dlg = + GWindow.dialog ~parent:window ~modal:true + ~position:`CENTER_ON_PARENT ~title:"Open package" () in + dlg#add_button "Open package" `OPEN; + dlg#add_button "Cancel" `CANCEL; + let vbox = dlg#vbox in + let hbox = GPack.hbox ~packing:vbox#pack () in + ignore (GMisc.label ~text:"Package:" ~packing:hbox#pack ()); + let entry = GEdit.entry + ~width_chars:40 ~packing:(hbox#pack ~expand:true ~fill:true) () in + ignore (GMisc.label ~text:"Enter a package name, wildcard or path." + ~packing:vbox#pack ()); + dlg#show (); + match dlg#run () with + | `CANCEL | `DELETE_EVENT -> + dlg#destroy () + | `OPEN -> + let pkgstr = entry#text in + dlg#destroy (); + if pkgstr <> "" then + defer (fun () -> open_package pkgstr) + in + ignore (open_item#connect#activate ~callback); + (* Need to enable these mouse events so we can do tooltips. *) GtkBase.Widget.add_events da#as_widget [`ENTER_NOTIFY; `LEAVE_NOTIFY; `POINTER_MOTION]; @@ -352,13 +502,7 @@ let () = add_locn, reset_locns, get_locn 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 pango_small_context = da#misc#create_pango_context in - pango_small_context#set_font_description (Pango.Font.from_string "Sans 8"); - - let repaint _ = + 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; @@ -410,10 +554,10 @@ let () = ) 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 *) + (* 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; @@ -448,9 +592,9 @@ let () = Package: %.1f%% %s (%Ld bytes) Incremental: %.1f%% %s (%Ld bytes) Total: %.1f%% %s (%Ld bytes)" pkg.nevra -(display_percent pkg.size) (display_size pkg.size) pkg.size -(display_percent increm) (display_size increm) increm -(display_percent total) (display_size total) total + (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 ) @@ -461,9 +605,9 @@ Total: %.1f%% %s (%Ld bytes)" pkg.nevra Package: %.1f%% %s (%Ld bytes) Incremental: %.1f%% %s (%Ld bytes) Total: %.1f%% %s (%Ld bytes)" pkg.nevra -(display_percent pkg.size) (display_size pkg.size) pkg.size -(display_percent increm) (display_size increm) increm -(display_percent total) (display_size total) total + (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 ) @@ -474,9 +618,9 @@ Total: %.1f%% %s (%Ld bytes)" pkg.nevra Pkg: %.1f%% %s (%Ld bytes) Incr: %.1f%% %s (%Ld bytes) Tot: %.1f%% %s (%Ld bytes)" pkg.name -(display_percent pkg.size) (display_size pkg.size) pkg.size -(display_percent increm) (display_size increm) increm -(display_percent total) (display_size total) total + (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 ) @@ -487,9 +631,9 @@ Tot: %.1f%% %s (%Ld bytes)" pkg.name Pkg: %.1f%% %s Incr: %.1f%% %s Tot: %.1f%% %s" pkg.name -(display_percent pkg.size) (display_size pkg.size) -(display_percent increm) (display_size increm) -(display_percent total) (display_size total) + (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 ) @@ -498,9 +642,9 @@ Tot: %.1f%% %s" pkg.name Pango.Layout.set_text txt ( sprintf "%s\nPkg: %.1f%%\nIncr: %.1f%%\nTot: %.1f%%" pkg.name - (display_percent pkg.size) - (display_percent increm) - (display_percent total) + (display_percent pkg.size top_total) + (display_percent increm top_total) + (display_percent total top_total) ); txt ) @@ -508,9 +652,9 @@ Tot: %.1f%% %s" pkg.name 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) (display_size pkg.size) - (display_percent increm) (display_size increm) - (display_percent total) (display_size total) + (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 ) @@ -518,9 +662,9 @@ Tot: %.1f%% %s" pkg.name let txt = pango_small_context#create_layout in Pango.Layout.set_text txt ( sprintf "%s %.1f%% %.1f%% %.1f%%" pkg.name - (display_percent pkg.size) - (display_percent increm) - (display_percent total) + (display_percent pkg.size top_total) + (display_percent increm top_total) + (display_percent total top_total) ); txt ) @@ -564,14 +708,21 @@ Tot: %.1f%% %s" pkg.name `RGB (r * 9 / 10, g * 9 / 10, b * 9 / 10) | _ -> `WHITE in - draw_tree 0. 0 tree; + draw_tree 0. 0 tree + + and repaint _ = + (match !current 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 motion ev = + 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 () = @@ -598,19 +749,53 @@ Tot: %.1f%% %s" pkg.name Package: %.1f%% %s (%Ld bytes) Incremental: %.1f%% %s (%Ld bytes) Total: %.1f%% %s (%Ld bytes)" pkg.nevra -(display_percent pkg.size) (display_size pkg.size) pkg.size -(display_percent increm) (display_size increm) increm -(display_percent total) (display_size total) total in + (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 !current 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 diff --git a/rpmdepsize_about.ml.in b/rpmdepsize_about.ml.in new file mode 100644 index 0000000..143573a --- /dev/null +++ b/rpmdepsize_about.ml.in @@ -0,0 +1,55 @@ +(* rpmdepsize - visualize the size of RPM dependencies + * @configure_input@ + * (C) Copyright 2009 Red Hat Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + * + * Written by Richard W.M. Jones + *) + +let callback _ = + let name = "@PACKAGE_NAME@" in + let version = "@PACKAGE_VERSION@" in + let authors = ["Richard W.M. Jones "] in + let website = "http://et.redhat.com/~rjones/rpmdepsize/" in + let website_label = "@PACKAGE_NAME@ website" in + let utf8_copyright = "\194\169" in + let copyright = utf8_copyright ^ " 2009 Red Hat Inc." in + let license = "\ +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA." in + let dlg = + GWindow.about_dialog + ~name + ~version + ~authors + ~website + ~website_label + ~copyright + ~license + () in + ignore (dlg#run ()); + dlg#destroy () diff --git a/rpmdepsize_errors.ml b/rpmdepsize_errors.ml new file mode 100644 index 0000000..3b5ba13 --- /dev/null +++ b/rpmdepsize_errors.ml @@ -0,0 +1,68 @@ +(* rpmdepsize - visualize the size of RPM dependencies + * (C) Copyright 2009 Red Hat Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + * + * Written by Richard W.M. Jones + * + * Some universal code to handle exceptions. + *) + +open Printf +open Unix + +let () = + let display_error title msg = + let icon = GMisc.image () in + icon#set_stock `DIALOG_ERROR; + icon#set_icon_size `DIALOG; + GToolbox.message_box ~title ~icon msg + in + + let unexpected exn_name err = + sprintf "Unexpected %s exception:\n\n%s\n\nPlease report this error to the software authors" exn_name err + in + + GtkSignal.user_handler := + function + | Unix_error (err, syscall, filename) -> + display_error + "Filesystem error" + (syscall ^ ": " ^ filename ^ ": " ^ error_message err) + | Sys_error err -> + display_error + "System error" + err + | Invalid_argument err -> + display_error + "Invalid argument" + (unexpected "Invalid_argument" err) + | Failure err -> + display_error + "Internal error" + (unexpected "Failure" err) + | Assert_failure (err, start, end_) -> + display_error + "Assertion failure" + (unexpected "Assertion_failure" + (err ^ " (" ^ string_of_int start ^ ", " ^ string_of_int end_)) + | Glib.GError err -> + display_error + "Gtk Internal error" + (unexpected "GLib.GError" err) + | exn -> + display_error + "Error" + (unexpected "internal" (Printexc.to_string exn))