summaryrefslogtreecommitdiff
path: root/rpmorphan-tk-lib.pl
diff options
context:
space:
mode:
Diffstat (limited to 'rpmorphan-tk-lib.pl')
-rw-r--r--rpmorphan-tk-lib.pl441
1 files changed, 441 insertions, 0 deletions
diff --git a/rpmorphan-tk-lib.pl b/rpmorphan-tk-lib.pl
new file mode 100644
index 0000000..0c0893e
--- /dev/null
+++ b/rpmorphan-tk-lib.pl
@@ -0,0 +1,441 @@
+#!/usr/bin/perl
+###############################################################################
+# rpmorphan-tk-lib.pl
+#
+# Copyright (C) 2006 by Eric Gerbier
+# Bug reports to: gerbier@users.sourceforge.net
+# $Id: rpmorphan-1.11 | rpmorphan-tk-lib.pl | Wed Jul 6 14:15:24 2011 +0000 | gerbier $
+#
+# 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.
+#
+###############################################################################
+# this file contains all tk code for rpmorphan gui
+###############################################################################
+
+use strict;
+use warnings;
+
+use English '-no_match_vars';
+
+## no critic(ProhibitPackageVars)
+use vars
+ qw( $W_list $Opt_dry_run $Inloop @Liste_pac &display_total &insert_gui_orphans );
+## use critic
+
+################################################################
+# select all
+sub tk_select_callback() {
+
+ $W_list->selectionSet( 0, 'end' );
+ return;
+}
+################################################################
+# unselect all
+sub tk_unselect_callback() {
+
+ $W_list->selectionClear( 0, 'end' );
+ return;
+}
+#########################################################
+# change cursor to watch
+sub tk_cursor2watch() {
+
+ my $cursor = $W_list->cget('-cursor');
+ $W_list->configure( -cursor => 'watch' );
+ $W_list->update();
+
+ return $cursor;
+}
+#########################################################
+# restore cursor
+sub tk_cursor2normal($) {
+ my $cursor = shift @_; # saved cursor
+
+ # restore pointer
+ $W_list->configure( -cursor => $cursor );
+ $W_list->update();
+ return;
+}
+#########################################################
+# remove selected packages
+sub tk_remove_callback($) {
+ my $main = shift @_; # parent widget
+
+ # change pointer
+ my $cursor = tk_cursor2watch();
+
+ # get full list
+ my @liste = $W_list->get( 0, 'end' );
+
+ # get selected items
+ my @sel = $W_list->curselection();
+
+ #transform index into names
+ my @selnames = map { $liste[$_] } @sel;
+
+ # confirm dialog
+ my $answer = tk_dialog( $main, 'confirm', "confirm remove @selnames ?" );
+
+ if ( $answer =~ m/Yes/ ) {
+
+ remove_packages( \@selnames, \@liste );
+ }
+
+ # restore pointer
+ tk_cursor2normal($cursor);
+ return;
+}
+#########################################################
+# general text display in a new text window
+# is used by all help buttons
+sub tk_display_message($$@) {
+ my $main = shift @_; # parent widget
+ my $title = shift @_; # window title
+ my @baratin = @_; # text to display
+
+ my $top = $main->Toplevel( -title => $title );
+ $top->Button( -text => 'quit', -command => [ $top => 'destroy' ] )->pack();
+ my $text = $top->Scrolled(
+ 'ROText',
+ -scrollbars => 'e',
+ -height => 25,
+ -width => 128,
+ -wrap => 'word'
+ )->pack( -side => 'left', -expand => 1, -fill => 'both' );
+ $top->bind( '<Key-q>', [ $top => 'destroy' ] );
+
+ $text->insert( 'end', @baratin );
+ $text->see('1.0');
+ return;
+}
+
+################################################################
+# general dialog
+sub tk_dialog($$$) {
+ my $main = shift @_; # parent widget
+ my $title = shift @_; # window title
+ my $baratin = shift @_; # text to display
+
+ my $dialog = $main->Dialog(
+ -text => $baratin,
+ -default_button => 'Yes',
+ -buttons => [qw/Yes No/]
+ );
+ my $answer = $dialog->Show();
+
+ return $answer;
+}
+################################################################
+# display help text
+sub tk_help_callback($) {
+ my $main = shift; # parent widget
+
+ my $baratin = get_help_text();
+
+ tk_display_message( $main, 'help', $baratin );
+ return;
+}
+################################################################
+# display log file
+sub tk_log_callback($) {
+ my $main = shift; # parent widget
+
+ my @l = get_log();
+ my $l = join "\n", @l;
+
+ tk_display_message( $main, 'help', $l );
+ return;
+}
+#########################################################
+# return name of current package
+sub tk_get_current_elem() {
+
+ # get current position
+ my $elem = $W_list->get('active');
+
+ # this code will be used if we display more
+ # than name on each line
+ # my $space = q{ };
+ # my @c = split /$space/, $elem;
+ # my $c = $c[0];
+ # return $c;
+
+ return $elem;
+}
+#########################################################
+# display package summary
+sub tk_summary_callback($) {
+ my $main = shift @_; # parent widget
+
+ my $c = tk_get_current_elem();
+ if ($c) {
+ tk_popup( $main, get_package_summary($c) );
+ }
+ else {
+ print "no current element selected\n";
+ }
+
+ return;
+}
+################################################################
+# display package info
+sub tk_info_callback($) {
+ my $main = shift @_; # parent widget
+
+ # get current position
+ my $c = tk_get_current_elem();
+
+ my @res = get_package_info($c);
+ chomp @res;
+ my $message = join "\n", @res;
+
+ tk_display_message( $main, 'info', $message );
+ return;
+}
+#########################################################
+# for reload button
+sub tk_load_callback($) {
+ my $main = shift @_; # parent widget
+
+ load_data(1);
+
+ return;
+}
+#########################################################
+# is called when an item is selected/unselected
+# and change a counter
+sub tk_list_callback {
+ my $widget = shift @_;
+ my $selected = shift @_;
+
+ # get selected items
+ my @sel = $W_list->curselection();
+
+ my $nb = scalar @sel;
+
+ $selected->delete( '1.0', 'end' );
+ $selected->insert( '1.0', $nb );
+
+ return;
+}
+#########################################################
+# common sub for button and key
+sub tk_quit($) {
+ my $main = shift @_;
+ $main->destroy();
+
+ return;
+}
+#########################################################
+sub tk_popup($$) {
+ my $main = shift @_;
+ my $message = shift @_;
+
+ my $top = $main->Toplevel();
+ $top->title('popup');
+ my $d = $top->Message( -text => $message );
+ $d->pack();
+ $d->focus();
+ $top->update();
+
+ # wait 1 second and destroy popup
+ ## no critic (ProhibitMagicNumbers)
+ $main->after(1000);
+
+ $top->destroy();
+
+ return;
+}
+#########################################################
+sub build_tk_gui() {
+
+ my $main = MainWindow->new( -title => build_title() );
+ my $w_balloon = $main->Balloon();
+ my $side = 'top';
+
+ # frame for buttons
+ ###################
+ my $frame1 = $main->Frame();
+ $frame1->pack( -side => 'top', -expand => 0, -fill => 'none' );
+
+ # remove
+ my $remove_button = $frame1->Button(
+ -text => 'Remove',
+ -command => [ \&tk_remove_callback, $main ],
+ );
+ $remove_button->pack( -side => 'left' );
+ $w_balloon->attach( $remove_button, -msg => 'remove selected packages' );
+ if ( is_remove_allowed($Opt_dry_run) ) {
+
+ $main->bind( '<Key-r>', [ \&tk_remove_callback, $main ] );
+ $main->bind( '<Key-x>', [ \&tk_remove_callback, $main ] );
+ }
+ else {
+ $remove_button->configure( -state => 'disabled' );
+ }
+
+ # info
+ my $info_button = $frame1->Button(
+ -text => 'Info',
+ -command => [ \&tk_info_callback, $main ],
+ );
+ $info_button->pack( -side => 'left' );
+ $w_balloon->attach( $info_button, -msg => 'get info on current package' );
+ $main->bind( '<Key-i>', [ \&tk_info_callback, $main ] );
+
+ # select all
+ my $select_button = $frame1->Button(
+ -text => 'Select all',
+ -command => [ \&tk_select_callback ],
+ );
+ $select_button->pack( -side => 'left' );
+ $w_balloon->attach( $select_button, -msg => 'select all packages' );
+ $main->bind( '<Key-s>', [ \&tk_select_callback ] );
+
+ # unselect all
+ my $unselect_button = $frame1->Button(
+ -text => 'Unselect all',
+ -command => [ \&tk_unselect_callback ],
+ );
+ $unselect_button->pack( -side => 'left' );
+ $w_balloon->attach( $unselect_button, -msg => 'unselect all packages' );
+ $main->bind( '<Key-u>', [ \&tk_unselect_callback ] );
+
+ # log
+ my $log_button = $frame1->Button(
+ -text => 'Log',
+ -command => [ \&tk_log_callback, $main ],
+ );
+ $log_button->pack( -side => 'left' );
+ $w_balloon->attach( $log_button, -msg => 'display log' );
+ $main->bind( '<Key-l>', [ \&tk_log_callback, $main ] );
+
+ # reload button
+ my $reload_button = $frame1->Button(
+ -text => 'reLoad',
+ -command => [ \&tk_load_callback, $main ]
+ );
+ $reload_button->pack( -side => 'left' );
+ $w_balloon->attach( $reload_button, -msg => 'reload rpm database' );
+ $main->bind( '<Key-L>', [ \&tk_load_callback, $main ] );
+
+ # help
+ my $help_button = $frame1->Button(
+ -text => 'Help',
+ -command => [ \&tk_help_callback, $main ],
+ );
+ $help_button->pack( -side => 'left' );
+ $w_balloon->attach( $help_button, -msg => 'help on rpmorphan interface' );
+ $main->bind( '<Key-h>', [ \&tk_help_callback, $main ] );
+
+ # quit
+ my $exit_button =
+ $frame1->Button( -text => 'Quit', -command => [ \&tk_quit, $main ] );
+ $exit_button->pack( -side => 'left' );
+ $w_balloon->attach( $exit_button, -msg => 'quit the software' );
+ $main->bind( '<Key-q>', [ \&tk_quit, $main ] );
+
+ # frame for the list
+ ####################
+ my $frame2 = $main->Frame();
+ $frame2->pack( -side => $side, -expand => 1, -fill => 'both' );
+
+ $W_list = $frame2->Scrolled(
+ 'Listbox',
+ -scrollbars => 'e',
+ -selectmode => 'multiple'
+ )->pack( -side => $side, -expand => 1, -fill => 'both' );
+
+ $w_balloon->attach( $W_list, -msg => 'list window' );
+
+ # for summary
+ $main->bind( '<Key-S>', [ \&tk_summary_callback, $main ] );
+
+ # button 3 : full info
+ $main->bind( '<Button-3>', [ \&tk_info_callback, $main ] );
+
+ # frame for status
+ ###################
+ my $frame3 = $main->Frame();
+ $frame3->pack( -side => 'bottom', -expand => 0, -fill => 'none' );
+
+ # number of packages
+ $frame3->Label( -text => 'total' )->pack( -side => 'left' );
+ my $w_total = $frame3->ROText( -width => 4, -height => 1 );
+ $w_total->pack( -side => 'left', -expand => 0, );
+ $w_balloon->attach( $w_total, -msg => 'number of packages' );
+
+ # number of orphans
+ $frame3->Label( -text => 'orphans' )->pack( -side => 'left' );
+ my $w_orphans = $frame3->ROText( -width => 4, -height => 1 );
+ $w_orphans->pack( -side => 'left', -expand => 0, );
+ $w_balloon->attach( $w_orphans, -msg => 'number of orphans packages' );
+
+ # number of selected
+ $frame3->Label( -text => 'selected' )->pack( -side => 'left' );
+ my $w_selected = $frame3->ROText( -width => 4, -height => 1 );
+ $w_selected->pack( -side => 'left', -expand => 0, );
+ $w_balloon->attach( $w_selected, -msg => 'number of selected orphans' );
+
+ # to allow to show number of selected
+ $W_list->bind( '<<ListboxSelect>>', [ \&tk_list_callback, $w_selected ] );
+
+ # status
+ $frame3->Label( -text => 'status' )->pack( -side => 'left' );
+ my $w_status = $frame3->ROText( -width => 40, -height => 1 );
+ $w_status->pack( -side => 'left', -expand => 1, -fill => 'both' );
+ $w_balloon->attach( $w_status,
+ -msg => 'display informations on internal state' );
+
+ # for debuging
+ $main->bind( '<Key-d>', [ \&dump_struct ] );
+
+ # common gui subroutines with different coding
+ ##############################################
+ # define insert_gui_orphans as a ref to anonymous sub
+ *insert_gui_orphans = sub {
+ $W_list->delete( 0, 'end' );
+ $W_list->insert( 'end', @_ );
+
+ my $nb = scalar @_;
+ $w_orphans->delete( '1.0', 'end' );
+ $w_orphans->insert( '1.0', $nb );
+
+ # reset
+ $w_selected->delete( '1.0', 'end' );
+ $w_selected->insert( '1.0', 0 );
+ };
+
+ *display_status = sub {
+ my $text = shift @_;
+
+ debug($text);
+
+ $w_status->delete( '1.0', 'end' );
+ $w_status->insert( '1.0', $text );
+
+ # an update before the mainloop call cause a core dump
+ # so we have to test if we are before of after
+ $w_status->update() if $Inloop;
+ };
+
+ *display_total = sub {
+
+ # display orphans total
+ my $nb = scalar @Liste_pac;
+ $w_total->delete( '1.0', 'end' );
+ $w_total->insert( '1.0', $nb );
+ };
+ return;
+}
+
+#########################################################
+1;