#!/usr/bin/perl 
###############################################################################
#   rpmorphan.pl
#
#    Copyright (C) 2006 by Eric Gerbier
#    Bug reports to: gerbier@users.sourceforge.net
#    $Id: rpmorphan.pl 56 2007-04-27 09:28:49Z 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.
#
###############################################################################
use strict;
use warnings;

use English '-no_match_vars';

use Getopt::Long;    # arg analysis
use Pod::Usage;      # man page

use File::stat;      # get_last_access

use Data::Dumper;    # debug

###############################################################################
# global variables
###############################################################################

# widget list of packages for gui
my $W_list;

# to know if we are or not in mainloop
my $Inloop = 0;

# command line option for access_time test
my $Opt_access_time;

# command line option for dry-run (simulation mode)
my $Opt_dry_run;

# hash structures to be filled with rpm query
my %Provides;
my %Depends;
my %Requires;
my %Install_time;
my %Files;
my %Virtual;

# list of filtered packages
my @Liste_pac;

# the code should use no "print" calls
# but instead debug, warning, info calls
###############################################################################
# change debug subroutine
# this way seems better tahn previous one as
# - it does not need any "global" verbose variable
# - it suppress any verbose test (quicker)
sub init_debug($) {
	my $verbose = shift @_;

	# to avoid error messages
	no warnings 'redefine';

	if ($verbose) {

		#*debug = \&main::effective_debug;
		*debug = sub {
			my $text = $_[0];
			print "debug $text\n";
		};
	}
	else {
		*debug = sub { };
	}

	use warnings 'all';
	return;
}
###############################################################################
# used to print warning messages
sub warning($) {
	my $text = shift @_;
	warn "WARNING $text\n";
	return;
}
###############################################################################
# used to print normal messages
sub info($) {
	my $text = shift @_;
	print "$text\n";
	return;
}
###############################################################################
sub print_version() {
	info( "$0 version " . get_version() );
	return;
}
#########################################################
# for debuging
# dump internal structures
sub dump_struct() {
	print Dumper ( 'depends',  \%Depends );
	print Dumper ( 'virtuals', \%Virtual );

	display_status('dump done');
	return;
}
#########################################################
{

	# for gui, we will have to call this sub after each delete
	# as it is very expensive (file access)
	# we will use a cache
	#
	my %access_time;

# this is a filter : we will test if any file was accessed since $access_time days
# be careful : this code can be very slow
	sub access_time_filter($$$$) {
		my $name        = shift @_;    # package name
		my $rh_files    = shift @_;    # general hash of package files
		my $access_time = shift @_;    # option access-time
		my $now         = shift @_;    # current time

		my $ret;
		if ($access_time) {

			my $age;

			# test for cache
			if ( exists $access_time{$name} ) {

				# get from cache
				$age = $access_time{$name};
			}
			else {

				# not in cache : get it from file system
				my ( $last_time, $file ) =
				  get_last_access( $rh_files->{$name} );
				$age = diff_date( $now, $last_time );
				debug("last access on $file is $age days old");
				$access_time{$name} = $age;
			}

			if ( $age > $access_time ) {
				debug("keep package $name : old access ($age days)");
				$ret = 1;
			}
			else {
				debug("skip package $name : too recent access ($age days)");
				$ret = 0;
			}
		}
		else {

			# no filter
			$ret = 1;
		}
		return $ret;
	}
}
#########################################################
# return true is $name is an orphan
sub solve($$$$) {
	my $name        = shift @_;    # package name
	my $rh_provides = shift @_;    # general provide hash
	my $rh_depends  = shift @_;    # general dependencies hash
	my $rh_virtual  = shift @_;    # virtual package hash

	debug("(solve) : $name");

	my $flag_orphan = 1;
  PROVIDE: foreach my $prov ( @{ $rh_provides->{$name} } ) {

   # dependencies can be to "virtual" object : smtpdaemon, webclient, bootloader
   # for example, try "rpm -q --whatprovides webclient"
   # you will get many packages : elinks,kdebase-common,mozilla,wget,lynx ...

		# with this new algo, let's see an example
		# lilo and grub provide 'bootloader' virtual, which is necessary
		# If the 2 are installed, they will be shown all 2 as orphans
		# but if you remove one of them, the other is now longer orphan
		if ( exists $rh_virtual->{$prov} ) {

			# this feature is a virtual
			my @virtuals   = keys %{ $rh_virtual->{$prov} };
			my $nb_virtual = scalar @virtuals;
			if ( $nb_virtual == 1 ) {

				# name provide a virtual and is the only one
				# so it act as a real dependency
				$flag_orphan = 0;
				debug("$name is required by virtual @virtuals ($prov)");
				last PROVIDE;
			}
			else {

				# name provide virtual but is not the only one
				# we consider it an orphan
				debug("skip virtual $prov");
				next PROVIDE;
			}
		}

		if ( exists $rh_depends->{$prov} ) {

			# some packages depends from $prov ...
			$flag_orphan = 0;

			my @depends = keys %{ $rh_depends->{$prov} };
			debug("$name is required by @depends ($prov)");
			last PROVIDE;
		}
	}
	return $flag_orphan;
}
#########################################################
# use the slow "rpm -e --test" command
# but is quicker if used only on 1 package (no analysis)
# return true if is an orphan
sub quicksolve($) {
	my $name = shift @_;    # package name

	debug("(quicksolve) : $name");

	my $cmd = 'rpm -e --test ';

	my @depends = `$cmd $name 2>&1`;
	my $ret;
	if ( $#depends == -1 ) {

		#info($name);
		$ret = 1;
	}
	else {
		$ret = 0;
		debug("$name is required by @depends");
	}
	return $ret;
}
#########################################################
# used to check on option
sub is_set($$) {
	my $rh_opt = shift @_;    # hash of program arguments
	my $key    = shift @_;    # name of desired option

	my $r_value = $rh_opt->{$key};
	return ${$r_value};
}
#########################################################
# apply a filter on package list according program options
sub filter($$) {
	my $rh_opt      = shift @_;
	my $rh_list_pac = shift @_;

	display_status('apply filters');

	# we just want the list of keys
	my @list = keys %{$rh_list_pac};

	if ( is_set( $rh_opt, 'all' ) ) {
		debug('all');
		return @list;
	}
	else {
		debug('guess');

		my @filtered_list;
		if ( is_set( $rh_opt, 'guess-perl' ) ) {
			debug('guess-perl');
			my @res = grep { /^perl/ } @list;
			push @filtered_list, @res;
		}
		if ( is_set( $rh_opt, 'guess-python' ) ) {
			my @res = grep { /^python/ } @list;
			push @filtered_list, @res;
		}
		if ( is_set( $rh_opt, 'guess-pike' ) ) {
			my @res = grep { /^pike/ } @list;
			push @filtered_list, @res;
		}
		if ( is_set( $rh_opt, 'guess-ruby' ) ) {
			my @res = grep { /^ruby/ } @list;
			push @filtered_list, @res;
		}
		if ( is_set( $rh_opt, 'guess-common' ) ) {
			my @res = grep { /-common$/ } @list;
			push @filtered_list, @res;
		}
		if ( is_set( $rh_opt, 'guess-data' ) ) {
			my @res = grep { /-data$/ } @list;
			push @filtered_list, @res;
		}
		if ( is_set( $rh_opt, 'guess-doc' ) ) {
			my @res = grep { /-doc$/ } @list;
			push @filtered_list, @res;
		}
		if ( is_set( $rh_opt, 'guess-dev' ) ) {
			my @res = grep { /-devel$/ } @list;
			push @filtered_list, @res;
		}
		if ( is_set( $rh_opt, 'guess-lib' ) ) {
			my @res = grep { /^lib/ } @list;
			push @filtered_list, @res;
		}
		if ( is_set( $rh_opt, 'guess-custom' ) ) {
			my $regex = ${ $rh_opt->{'guess-custom'} };
			my @res = grep /$regex/, @list;
			push @filtered_list, @res;
		}
		return @filtered_list;
	}
}
#########################################################
# difference between 2 date in unix format
# return in days
sub diff_date($$) {
	my $now  = shift @_;    # current
	my $time = shift @_;    #

	# convert from seconds to days
	return int( ( $now - $time ) / 86_400 );
}
#########################################################
# return the date (unix format) of last access on a package
# (scan all inodes for atime) and the name of the file
sub get_last_access($) {
	my $ra_files = shift @_;    # array of file names

	my $last_date = 0;          # means a very old date for linux : 1970
	my $last_file = q{};
  FILE: foreach my $file ( @{$ra_files} ) {
		next FILE unless ( -e $file );
		my $stat  = stat $file;
		my $atime = $stat->atime();

		if ( $atime > $last_date ) {
			$last_date = $atime;
			$last_file = $file;
		}
	}
	return ( $last_date, $last_file );
}
#########################################################
# read rpm information about all installed packages
# can be from database, or from rpmorphan cache
sub read_rpm_data($$$$$$) {
	my $rh_opt          = shift @_;    # hash of program arguments
	my $rh_provides     = shift @_;
	my $rh_install_time = shift @_;
	my $rh_files        = shift @_;
	my $rh_depends      = shift @_;
	my $rh_virtual      = shift @_;

	# the main idea is to reduce the number of call to rpm in order to gain time
	# the ';' separator is used to separate fields
	# the ' ' separator is used to separate data in fields arrays

# note : we do not ask for PROVIDEFLAGS PROVIDEVERSION REQUIREFLAGS REQUIREVERSION
	my $rpm_cmd =
'rpm -qa --queryformat "%{NAME};[%{REQUIRENAME} ];[%{PROVIDES} ];[%{FILENAMES} ];%{INSTALLTIME}\n" ';
	my $cmd;

	my $cache_file = '/tmp/rpmorphan.cache';
	my $fh_cache;

	if ( is_set( $rh_opt, 'clear-cache' ) ) {
		unlink $cache_file if ( -f $cache_file );
	}

	if ( is_set( $rh_opt, 'use-cache' ) ) {
		if ( -f $cache_file ) {

			# cache exists : use it
			$cmd = $cache_file;
			display_status("use cache file $cache_file");
		}
		else {

			# use rpm command
			$cmd = "$rpm_cmd |";

			# and create cache file
			open( $fh_cache, '>', $cache_file )
			  or warning("can not create cache file $cache_file : $!");
			display_status("create cache file $cache_file");
		}
	}
	else {
		$cmd = "$rpm_cmd |";
		display_status('read rpm data');

		unlink $cache_file if ( -f $cache_file );
	}

	# output may be long, so we use a pipe to avoid to store a big array
	my %objects;
	my $fh;
	open( $fh, $cmd ) or die "can not open $cmd : $!\n";
	debug('1 : analysis');
	while (<$fh>) {

		# write cache
		print {$fh_cache} $_ if ($fh_cache);

		my ( $name, $req, $prov, $files, $install_time ) = split /;/, $_;

		# we do not use version in keys
		# so we only keep the last seen data for a package name
		if ( exists $rh_provides->{$name} ) {
			debug("duplicate package $name");
		}

		# install time are necessary for install-time option
		$rh_install_time->{$name} = $install_time;

		my $space = q{ };
		my @prov  = split /$space/, $prov;
		my @req   = split /$space/, $req;
		my @files = split /$space/, $files;

		# try to detect virtuals
		# virtuals can be provided by several packages
		# see comments in solve sub
		# files are added, because a directory may be declared by 2 packages !
		# (ex /etc/cron.daily by crontab and afick)
	  VIRTUAL: foreach my $p ( @prov, @files ) {

			# do not add files
			#next VIRTUAL if ( $p =~ m!^/! );

			#  some bad package may provide more than on time the same object
			if (   ( exists $objects{$p} )
				&& ( $objects{$p} ne $name ) )
			{

				# method 1 (old)
				# we do not use who provide this virtual for now
				#$rh_virtual->{$p} = 1;

				# method 2 (current)
				# to improve the code, we can use virtual as a counter
				# ( as a garbage collector )
				# so we can remove all providing except the last one
				if ( !exists $rh_virtual->{$p} ) {

					# add previous data
					$rh_virtual->{$p}{ $objects{$p} } = 1;
				}

				# add new virtual
				$rh_virtual->{$p}{$name} = 1;
			}
			else {

				# keep memory of seen "provided"
				$objects{$p} = $name;
			}
		}

		# $name package provide @prov
		# file are also included in "provide"
		push @{ $rh_provides->{$name} }, @prov, @files;

		# list are necessary for access-time option
		push @{ $rh_files->{$name} }, @files;

		# this will be helpfull when recursive remove package
		push @{ $Requires{$name} }, @req;

		# build a hash for dependencies
		foreach my $require (@req) {

			# we have to suppress auto-depends (ex : ark package)
			my $flag_auto = 0;
		  PROVIDE: foreach my $p (@prov) {
				if ( $require eq $p ) {
					$flag_auto = 1;

					#debug("skip auto-depency on $name");
					last PROVIDE;
				}
			}

	   # $name depends from $require
	   # exemple : depends { 'afick' } { afick-gui } = 1
	   #push @{ $rh_depends->{$require} }, $name unless $flag_auto;
	   # we use a hash to help when we have to delete data (on recursive remove)
			$rh_depends->{$require}{$name} = 1 unless $flag_auto;
		}

	}
	close $fh;
	close $fh_cache if ($fh_cache);
	return;
}
##########################################################
## build a hash of package summaries
## no cache for now
#{
#	my %summary;
#	sub build_summary(@) {
#		my @list = @_;
#
#		my $cmd = "rpm -q --queryformat '%{NAME}:%{SUMMARY}\n' @list";
#		open (my $fh_summary, "$cmd |");
#		while(my $line = <$fh_summary>) {
#			chomp $line;
#			my ($package, $sum) = split /:/, $line;
#			$summary{$package} = $sum;
#		}
#		close $fh_summary;
#
#		return;
#	}
#	sub get_summary($) {
#		my $pac = shift @_;
#		return $summary{$pac};
#	}
#}
#
##########################################################
# resolv dependencies for all packages in ra_liste_pac
sub search_orphans($$$$$$$) {
	my $rh_provides     = shift @_;
	my $rh_files        = shift @_;
	my $rh_depends      = shift @_;
	my $rh_virtual      = shift @_;
	my $now             = shift @_;
	my $ra_liste_pac    = shift @_;    # list of all packages
	my $opt_access_time = shift @_;

	display_status('4 : solve');
	my @orphans;
	foreach my $pac ( @{$ra_liste_pac} ) {
		if (    solve( $pac, $rh_provides, $rh_depends, $rh_virtual, )
			and access_time_filter( $pac, $rh_files, $opt_access_time, $now ) )
		{
			push @orphans, $pac;
		}
	}
	return @orphans;
}
#########################################################
# remove entries from lists for a package
sub remove_a_package($) {
	my $pacname = shift @_;

	# first remove dependencies
  PROVIDE: foreach my $req ( @{ $Requires{$pacname} } ) {

		delete $Depends{$req}{$pacname};
		debug("delete Depends { $req } {$pacname}");

		# suppress entry if empty
		my $keys = scalar keys %{ $Depends{$req} };
		if ( !$keys ) {
			delete $Depends{$req};
			debug("delete empty Depends { $req }");
		}
	}

	# remove virtuals
  VIRT: foreach my $prov ( @{ $Provides{$pacname} } ) {
		if ( exists $Virtual{$prov} ) {
			delete $Virtual{$prov}{$pacname};
			debug("delete Virtual { $prov }{ $pacname }");

			# suppress entry if empty
			my $keys = scalar keys %{ $Virtual{$prov} };
			if ( !$keys ) {
				delete $Virtual{$prov};
				debug("delete empty Virtual { $prov }");
			}
		}
	}

	# then delete all entries
	delete $Provides{$pacname};
	delete $Files{$pacname};
	delete $Install_time{$pacname};
	delete $Requires{$pacname};

	return;
}
#########################################################
# a generic program to be called by curses or tk sub
sub remove_packages($$) {
	my $ra_sel  = shift @_;    # list of select packages
	my $ra_list = shift @_;    # list of all orphans packages

	# remove package
  SELECT: foreach my $pac ( @{$ra_sel} ) {
		if ( !$Opt_dry_run ) {

			# not in dry mode : apply change

			# rpm delete
			my $cmd = "rpm -e $pac 2>&1";

			# comment below to test without any real suppress
			my @output = `$cmd`;

			#print "@output\n";

			# reports
			write_log("$pac deleted");
		}

		# update internal lists
		remove_a_package($pac);
	}

	# build a new list of all packages without the removed ones
	my @new_list;
  LISTE: foreach my $l (@Liste_pac) {
		foreach my $pac ( @{$ra_sel} ) {
			next LISTE if ( $pac eq $l );
		}
		push @new_list, $l;
	}
	@Liste_pac = @new_list;
	display_total();

	# compute new dependencies
	my $now = time;
	my @orphans =
	  search_orphans( \%Provides, \%Files, \%Depends, \%Virtual, $now,
		\@new_list, $Opt_access_time );

	# display
	insert_gui_orphans(@orphans);

	#build_summary(@new_list);

	display_status('end of cleaning');
	return;
}
#########################################################
# read all existing rc file from general to local :
# host, home, local directory
sub readrc($) {

	my $rh_list = shift @_;    # list of available parameters

	# can use local rc file, home rc file, host rc file
	my @list_rc =
	  ( '/etc/rpmorphanrc', $ENV{HOME} . '/.rpmorphanrc', '.rpmorphanrc', );

	foreach my $rcfile (@list_rc) {

		if ( -f $rcfile ) {
			debug("read rc from $rcfile");
			my $fh_rc;
			if ( open( $fh_rc, '<', $rcfile ) ) {

				# perl cookbook, 8.16
				my $line = 1;
			  RC: while (<$fh_rc>) {
					chomp;
					s/#.*//;     # comments
					s/^\s+//;    # skip spaces
					s/\s+$//;
					next RC unless length;
					my ( $key, $value ) = split /\s*=\s*/, $_, 2;
					if ( defined $key ) {
						if ( exists $rh_list->{$key} ) {
							${ $rh_list->{$key} } = $value;

					   # special case : verbose will modify immediately behavior
							init_debug($value) if ( $key eq 'verbose' );

							debug(
"rcfile : found $key parameter with $value value"
							);
						}
						else {
							warning(
"bad $key parameter in line $line in $rcfile file"
							);
						}
					}
					else {
						warning("bad line $line in $rcfile file");
					}
					$line++;
				}
				close $fh_rc;
			}
			else {
				warning("can not open rcfile $rcfile : $!");
			}
		}
		else {
			debug("no rcfile $rcfile found");
		}
	}
	return;
}
#########################################################
# because arg can be given in one or several options :
# --add toto1 --add toto2
# --add toto1,toto2
sub get_from_command_line(@) {
	my @arg = @_;

	my $comma = q{,};
	return split /$comma/, join( $comma, @arg );
}
#########################################################
# used to build windows's title
sub build_title() {

	my $title = 'rpmorphan version ' . get_version();
	$title .= ' (dry-run)' if $Opt_dry_run;
	return $title;
}
#########################################################
# 		keep
#
# a way to keep a list of exclusions
#########################################################
my $file_keep = '/var/lib/rpmorphan/keep';

# list content of keep file
sub list_keep($) {
	my $display = shift @_;    # display or not ?

	my @list;
	my $fh;
	if ( open( $fh, '<', $file_keep ) ) {
		@list = <$fh>;
		chomp @list;
		close $fh;

		info("@list") if ($display);
	}
	else {
		warning("can not read keep file $file_keep : $!");
	}
	return @list;
}
#########################################################
# empty keep file
sub zero_keep() {
	my $fh;
	if ( open( $fh, '>', $file_keep ) ) {
		close $fh;
	}
	else {
		warning("can not empty keep file $file_keep : $!");
	}
	return;
}
#########################################################
# add packages names to keep file
sub add_keep($$) {
	my $ra_list     = shift @_;
	my $flag_append = shift @_;    # true if append, else rewrite

	my @new_list;
	my $mode;
	if ($flag_append) {
		$mode = '>>';

		# read current list
		my @old_list = list_keep(0);

		# check for duplicates and merge
	  LOOP: foreach my $add ( @{$ra_list} ) {
			foreach my $elem (@old_list) {
				if ( $elem eq $add ) {
					debug("skip add duplicate $add");
					next LOOP;
				}
			}
			push @new_list, $add;
			debug("add keep $add");
		}
	}
	else {
		$mode     = '>';
		@new_list = @{$ra_list};
	}

	my $fh;
	if ( open( $fh, $mode, $file_keep ) ) {
		foreach my $elem (@new_list) {
			print {$fh} $elem . "\n";
		}
		close $fh;
	}
	else {
		warning("can not write to keep file $file_keep : $!");
	}
	return;
}
#########################################################
# remove packages names from keep file
sub del_keep($) {
	my $ra_list = shift @_;

	# read current list
	my @old_list = list_keep(0);

	# remove entries
	my @new_list;
  LOOP: foreach my $elem (@old_list) {
		foreach my $del ( @{$ra_list} ) {
			if ( $elem eq $del ) {
				debug("del keep $del");
				next LOOP;
			}
		}
		push @new_list, $elem;
	}

	# rewrite keep file
	add_keep( \@new_list, 0 );
	return;
}
################################################################
{

	# just to avoid a global var
	my @log;

	sub write_log {
		push @log, @_;
		display_status( shift @_ );
		return;
	}

	sub get_log() {
		return @log;
	}
}
################################################################
#                     tk  gui
################################################################
# 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 @_;

	# restore pointer
	$W_list->configure( -cursor => $cursor );
	$W_list->update();
	return;
}
#########################################################
# remove selected packages
sub tk_remove_callback() {

	# 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;

	remove_packages( \@selnames, \@liste );

	# restore pointer
	tk_cursor2normal($cursor);
	return;
}
#########################################################
# general texte 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;
}

################################################################
sub tk_help_callback($) {
	my $main = shift;

	my $baratin = get_help_text();

	tk_display_message( $main, 'help', $baratin );
	return;
}
################################################################
sub tk_log_callback($) {
	my $main = shift;

	my @l = get_log();
	my $l = join "\n", @l;

	tk_display_message( $main, 'help', $l );
	return;
}
#########################################################
sub tk_get_current_elem() {

	# get current position
	my $elem = $W_list->get('active');

	# todo : check this
	my $space = q{ };
	my @c = split /$space/, $elem;

	#print "selection : @c\n";
	my $c = $c[0];

	return $c;
}
#########################################################
sub tk_summary_callback() {

	my $c = tk_get_current_elem();
	display_status( get_summary($c) );

	return;
}
################################################################
sub tk_info_callback {
	my $main = shift @_;

	# get current position
	my $c = tk_get_current_elem();

	#print "c=$c\n";
	my $cmd = "rpm -qil $c";
	my @res = `$cmd`;
	chomp @res;

	my $message = join "\n", @res;

	tk_display_message( $main, 'info', $message );
	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;
}
#########################################################
# todo idea : write the summary of package in ROtext when cursor is on
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' );

	# only active remove button if executed on root user
	my $remove_button = $frame1->Button(
		-text    => 'Remove',
		-command => [ \&tk_remove_callback ]
	);
	$remove_button->pack( -side => 'left' );
	$w_balloon->attach( $remove_button, -msg => 'remove selected packages' );
	if ( ( $EFFECTIVE_USER_ID != 0 ) and ( !$Opt_dry_run ) ) {
		$remove_button->configure( -state => 'disabled' );
	}
	else {
		$main->bind( '<Key-r>', [ \&tk_remove_callback ] );
		$main->bind( '<Key-x>', [ \&tk_remove_callback ] );
	}

	# 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 ] );

	# 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 ] );

# todo
#my $resolve_button =
#$frame1->Button( -text => 'resolve', -command => [ \&tk_help_callback, $main ] );
#$resolve_button->pack( -side => 'left' );
#$w_balloon->attach( $resolve_button, -msg => 'resolve dependencies' );
#$main->bind( '<Key-r>', [\&tk_help_callback, $main] );

	# quit
	my $exit_button =
	  $frame1->Button( -text => 'Quit', -command => [ $main => 'destroy' ] );
	$exit_button->pack( -side => 'left' );
	$w_balloon->attach( $exit_button, -msg => 'quit the software' );
	$main->bind( '<Key-q>', [ $main => 'destroy' ] );

	# 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' );

	# button 1 : summary
	#$W_list->bind( '<Button-1>', [ \&tk_summary_callback ] );
	# button 3 : full info
	$W_list->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;
}
#########################################################
sub test_tk_gui() {

	# check if perl-tk is available
	eval {
		require Tk;
		require Tk::Balloon;
		require Tk::Frame;
		require Tk::Listbox;
		require Tk::ROText;
		require Tk::Label;
	};
	if ($EVAL_ERROR) {
		warning('can not find Tk perl module');
		return 0;
	}
	else {
		debug('Tk ok');
		import Tk;
		import Tk::Balloon;
		import Tk::Frame;
		import Tk::Listbox;
		import Tk::ROText;
		import Tk::Label;

		build_tk_gui();
		return 'tk';
	}
}
#########################################################
#			curses gui
#########################################################
sub curses_log_callback($;) {
	my $this = shift @_;

	my @l = get_log();

	@l = ('empty') if ( !@l );
	my $l = join "\n", @l;

	$this->root()->dialog(
		-message => $l,
		-buttons => ['ok'],
		-title   => 'log',
	);
	return;
}
#########################################################
# todo : fill this help
sub curses_help_callback($;) {
	my $this = shift @_;

	my $text = get_help_text();
	$this->root()->dialog(
		-message => $text,
		-buttons => ['ok'],
		-title   => 'help',
	);
	return;
}
#########################################################
# quit gui
sub curses_quit_callback($;) {
	my $this = shift @_;
	exit;
}
#########################################################
# a quick and dirty tool to display messages
# todo : rewrite it by using a status ( TextViewer )
sub curses_message($$) {
	my $widget  = shift @_;
	my $message = shift @_;

	my $cui = $widget->root();
	$cui->status($message);
	sleep 1;
	$cui->nostatus();

	return;
}
#########################################################
# select all
sub curses_select_callback($) {
	my $widget = shift;

	my $container = $widget->parent();
	my $listbox   = $container->getobj('list');

	my $pac_list = $W_list->values();
	my @pac2     = @{$pac_list};
	my @sel      = ( 0 .. $#pac2 );
	$listbox->set_selection(@sel);

	# update
	$listbox->draw();
	return;
}
#########################################################
# unselect all
sub curses_unselect_callback($) {
	my $widget = shift;

	my $container = $widget->parent();
	my $listbox   = $container->getobj('list');

	$listbox->clear_selection();

	# update
	$listbox->draw();
	return;
}
#########################################################
# remove selected items
sub curses_remove_callback($) {
	my $widget = shift;

	my $container = $widget->parent();
	my $listbox   = $container->getobj('list');
	my @sel       = $listbox->get();              # selected items

	# test for root acces
	if ( ( $EFFECTIVE_USER_ID != 0 ) and ( !$Opt_dry_run ) ) {
		curses_message( $widget, 'you should be root to remove packages' );
	}
	else {
		my $old_pac_list = $W_list->values();
		remove_packages( \@sel, $old_pac_list );

		# update
		$listbox->draw();
	}

	return;
}
#########################################################
# display rpm info on the current item
sub curses_summary_callback($) {
	my $widget  = shift;
	my $listbox = $widget->parent()->getobj('list');

	my $current = $listbox->get_active_value();

	display_status( get_summary($current) );
	return;
}

#########################################################
# display rpm info on the current item
sub curses_info_callback($) {
	my $widget  = shift;
	my $listbox = $widget->parent()->getobj('list');

	my $current = $listbox->get_active_value();

	my $empty = q{};
	my $txt;
	if ( defined $current ) {
		my @output = `rpm -qil $current`;
		$txt = join $empty, @output;
	}
	else {
		$txt = 'you should select a package';
	}

	# todo : problem with scrollbar
	# is it possible with a dialog ?
	# do this with a TextViewer ?
	my $dialog = $listbox->root()->dialog(
		-message    => $txt,
		-buttons    => ['ok'],
		-title      => 'info',
		-vscrollbar => 1,
	);
	return;
}
#########################################################
# is called when an item is selected/unselected
# and change a counter
sub curses_list_callback() {
	my $widget  = shift;
	my $listbox = $widget->parent()->getobj('list');
	my @sel     = $listbox->get();                     # selected items

	my $nb       = scalar @sel;
	my $selected = $widget->parent()->getobj('selected_val');
	$selected->text($nb);
	$selected->draw();

	return;
}
#########################################################
sub build_curses_gui() {

	# Create the root object.
	my $cui = new Curses::UI(
		-clear_on_exit => 0,
		-debug         => 0,
	);

	# add a window
	my $win1 = $cui->add(
		'win1',
		'Window',
		-title          => build_title(),
		-titlefullwidth => 1,
		-border         => 1,
	);

	# boutons
	$win1->add(
		'buttons',
		'Buttonbox',
		-y       => 0,
		-buttons => [
			{
				-label   => '< Remove >',
				-onpress => \&curses_remove_callback,
			},
			{
				-label   => '< Info >',
				-onpress => \&curses_info_callback,
			},
			{
				-label   => '< Select all >',
				-onpress => \&curses_select_callback,
			},
			{
				-label   => '< Unselect all >',
				-onpress => \&curses_unselect_callback,
			},
			{
				-label   => '< Log >',
				-onpress => \&curses_log_callback,
			},
			{
				-label   => '< Help >',
				-onpress => \&curses_help_callback,
			},
			{
				-label   => '< Quit >',
				-onpress => \&curses_quit_callback,
			},
		],
	);

	# listbox
	$W_list = $win1->add(
		'list', 'Listbox',
		-y           => 1,
		-width       => 60,
		-height      => 20,
		-border      => 1,
		-vscrollbar  => 1,
		-multi       => 1,
		-onselchange => \&curses_list_callback,
	);

	my $empty = q{};

	# total
	$win1->add(
		'total',
		'Label',
		-text => 'total',
		-x    => 1,
		-y    => 21,
	);
	my $w_total = $win1->add(
		'total_val',
		'TextViewer',
		-text   => $empty,
		-height => 1,
		-width  => 5,
		-x      => 7,
		-y      => 21,
	);

	# orphans
	$win1->add(
		'orphans',
		'Label',
		-text => 'orphans',
		-x    => 12,
		-y    => 21,
	);
	my $w_orphans = $win1->add(
		'orphans_val',
		'TextViewer',
		-text   => $empty,
		-height => 1,
		-width  => 5,
		-x      => 20,
		-y      => 21,
	);

	# selected
	$win1->add(
		'selected',
		'Label',
		-text => 'selected',
		-x    => 25,
		-y    => 21,
	);
	my $w_selected = $win1->add(
		'selected_val',
		'TextViewer',
		-text   => $empty,
		-height => 1,
		-width  => 4,
		-x      => 35,
		-y      => 21,
	);

	# status
	$win1->add(
		'label',
		'Label',
		-text => 'status:',
		-x    => 1,
		-y    => 22,
	);
	my $w_status = $win1->add(
		'status',
		'TextViewer',
		-text   => $empty,
		-height => 1,
		-width  => 50,
		-x      => 9,
		-y      => 22,
	);

	# begin on list
	$W_list->focus();

	# Bind <x> for remove
	$cui->set_binding( sub { curses_remove_callback($W_list) }, 'x' );
	$cui->set_binding( sub { curses_remove_callback($W_list) }, 'r' );

	# Bind <i> for info
	$cui->set_binding( sub { curses_info_callback($W_list) }, 'i' );

# todo : find a way to use button 3
#$W_list->set_mouse_binding('mouse-button3', BUTTON3_CLICKED());
#$W_list->set_binding( sub { curses_info_callback($W_list) }, 'mouse-button3' );

#$W_list->set_binding( sub { curses_summary_callback($W_list) }, 'mouse-button1' );

	# Bind <s> for select
	$cui->set_binding( sub { curses_select_callback($W_list) }, 's' );

	# Bind <u> for unselect
	$cui->set_binding( sub { curses_unselect_callback($W_list) }, 'u' );

	# Bind <l> for log
	$cui->set_binding( sub { curses_log_callback($W_list) }, 'l' );

	# Bind <h> for help
	$cui->set_binding( sub { curses_help_callback($W_list) }, 'h' );

	# Bind <q> to quit.
	$cui->set_binding( sub { exit }, 'q' );

	# for debuging
	#$cui->set_binding( sub { dump_struct() }, 'd' );

	# common gui subroutines with different coding
	##############################################
	*insert_gui_orphans = sub {
		$W_list->values(@_);

		# display orphans total
		my $nb = scalar @_;
		$w_orphans->text($nb);
		$w_orphans->draw();

		# reset selected
		$w_selected->text(0);
		$w_selected->draw();
	};

	# todo : choose
	#*display_status    = sub { curses_message( $W_list, shift @_ ); };
	*display_status = sub {
		my $text = shift @_;
		debug($text);

		$w_status->text($text);
		$w_status->draw();
	};

	*display_total = sub {

		# display orphans total
		my $nb = scalar @Liste_pac;
		$w_total->text($nb);
		$w_total->draw();
	};

	return;
}

#########################################################
sub test_curses_gui() {

	eval { require Curses::UI; };
	if ($EVAL_ERROR) {
		warning('can not find Curses::UI perl module');
		return 0;
	}
	else {
		debug('curses ok');
		import Curses::UI;

		build_curses_gui();
		return 'curses';
	}
}
#########################################################
#		general gui
#########################################################
sub test_gui() {
	return test_tk_gui() or test_curses_gui();
}
#########################################################
sub get_help_text() {

	my $baratin = 'rpmorphan will help you to clean unused package

the window will show you orphaned packages (without any rpm dependencies to them)

buttons are :

remove : remove selected package(s) 
info : show informations about current package
select all : select all packages
unselect all : unselect all packages
log    : display list of suppressed packages
help   : this help screen
quit   : exit rpmorphan

mouse :
- left click to select/unselect a package
- right click to display rpm informations

hotkeys :
x/r : remove
i : information
s : select all
u : unselect all
l : display log
h : help
q : quit

total : total number of packages (filtered by guess filter and exclude list)
orphans : number of packages resolved as orphans
selected : number of selected orphans
	
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.
	';
	return $baratin;
}
#########################################################
#	version
#########################################################
{
	my $version = '1.0';

	sub get_version() {
		return $version;
	}
}

#########################################################
#
#	main
#
#########################################################
my $opt_verbose = 0;    # default value
init_debug($opt_verbose);

my $opt_help;
my $opt_man;
my $opt_version;
my $opt_fullalgo;
my $opt_use_cache;
my $opt_clear_cache;
my $opt_gui;
my $opt_tk;
my $opt_curses;

my $opt_all;

my $opt_guess_perl;
my $opt_guess_python;
my $opt_guess_pike;
my $opt_guess_ruby;
my $opt_guess_common;
my $opt_guess_data;
my $opt_guess_doc;
my $opt_guess_dev;
my $opt_guess_lib;
my $opt_guess_all;
my $opt_guess_custom;

my @opt_package;
my @opt_exclude;
my $opt_install_time;

my $opt_list_keep;
my $opt_zero_keep;
my @opt_add_keep;
my @opt_del_keep;

my %opt = (
	'help'         => \$opt_help,
	'man'          => \$opt_man,
	'verbose'      => \$opt_verbose,
	'dry-run'      => \$Opt_dry_run,
	'version'      => \$opt_version,
	'fullalgo'     => \$opt_fullalgo,
	'all'          => \$opt_all,
	'guess-perl'   => \$opt_guess_perl,
	'guess-python' => \$opt_guess_python,
	'guess-pike'   => \$opt_guess_pike,
	'guess-ruby'   => \$opt_guess_ruby,
	'guess-common' => \$opt_guess_common,
	'guess-data'   => \$opt_guess_data,
	'guess-doc'    => \$opt_guess_doc,
	'guess-dev'    => \$opt_guess_dev,
	'guess-lib'    => \$opt_guess_lib,
	'guess-all'    => \$opt_guess_all,
	'guess-custom' => \$opt_guess_custom,
	'package'      => \@opt_package,
	'exclude'      => \@opt_exclude,
	'install-time' => \$opt_install_time,
	'access-time'  => \$Opt_access_time,
	'add-keep'     => \@opt_add_keep,
	'del-keep'     => \@opt_del_keep,
	'list-keep'    => \$opt_list_keep,
	'zero-keep'    => \$opt_zero_keep,
	'use-cache'    => \$opt_use_cache,
	'clear-cache'  => \$opt_clear_cache,
	'gui'          => \$opt_gui,
	'tk'           => \$opt_tk,
	'curses'       => \$opt_curses,
);

# first read config file
readrc( \%opt );

# get arguments
Getopt::Long::Configure('no_ignore_case');
GetOptions(
	\%opt,            'help|?',         'man',         'verbose!',
	'fullalgo!',      'version|V',      'all!',        'guess-perl!',
	'guess-python!',  'guess-pike!',    'guess-ruby!', 'guess-common!',
	'guess-data!',    'guess-doc!',     'guess-dev!',  'guess-lib!',
	'guess-all!',     'guess-custom=s', 'package=s',   'exclude=s',
	'install-time=i', 'access-time=i',  'list-keep',   'zero-keep',
	'add-keep=s',     'del-keep=s',     'use-cache!',  'clear-cache',
	'gui!',           'tk!',            'curses!',     'dry-run!',
) or pod2usage(2);

if ($opt_help) {
	pod2usage(1);
}
elsif ($opt_man) {
	pod2usage( -verbose => 2 );
}
elsif ($opt_version) {
	print_version();
	exit;
}

# use command line argument
init_debug($opt_verbose);

# keep file management
if ($opt_list_keep) {
	list_keep(1);
	exit;
}
if ($opt_zero_keep) {
	zero_keep();
	exit;
}
if (@opt_add_keep) {
	my @liste_add = get_from_command_line(@opt_add_keep);
	add_keep( \@liste_add, 1 );
	exit;
}
if (@opt_del_keep) {
	my @liste_del = get_from_command_line(@opt_del_keep);
	del_keep( \@liste_del );
	exit;
}

if ($opt_guess_all) {
	$opt_guess_perl   = 1;
	$opt_guess_python = 1;
	$opt_guess_pike   = 1;
	$opt_guess_ruby   = 1;
	$opt_guess_common = 1;
	$opt_guess_data   = 1;
	$opt_guess_doc    = 1;
	$opt_guess_dev    = 1;
	$opt_guess_lib    = 1;
}

my $is_guess = $opt_guess_perl
  || $opt_guess_python
  || $opt_guess_pike
  || $opt_guess_ruby
  || $opt_guess_common
  || $opt_guess_data
  || $opt_guess_doc
  || $opt_guess_dev
  || $opt_guess_lib
  || $opt_guess_custom;

# test if a target is set
if ( ( !@opt_package ) && ( !$opt_all ) && ( !$is_guess ) ) {
	pod2usage('need a target : --package , --all, or --guess_? ');
}

# excluded files
my %excluded;

# first : permanent "keep" file
my @list_keep = list_keep(0);
foreach my $ex (@list_keep) {
	$excluded{$ex} = 1;
	debug("conf : permanent exclude $ex");
}

# command options
if (@opt_exclude) {

	#allow comma separated options on tags option
	# and build a hash for faster access
	my @liste_ex = get_from_command_line(@opt_exclude);
	foreach my $ex (@liste_ex) {
		$excluded{$ex} = 1;
		debug("conf : exclude $ex");
	}
}

# install-time and access-time options are only available with the full algo
if ( ($opt_install_time) or ($Opt_access_time) ) {
	debug('forced full algo');
	$opt_fullalgo = 1;
}

# if only few packages, the big algo is not necessary
# quicksolve algo will be faster
if (@opt_package) {

	#allow comma separated options on tags option
	@opt_package = get_from_command_line(@opt_package);

	if ( !$opt_fullalgo ) {
		if ( $#opt_package <= 5 ) {

			# use  quicksolve
		  PAC: foreach my $pac (@opt_package) {
				if ( exists $excluded{$pac} ) {
					debug("skip $pac : excluded");
					next PAC;
				}
				info($pac) if ( quicksolve($pac) );
			}
			exit;
		}
		else {
			debug('too much package for quicksolve algo');
		}
	}
	else {
		debug('full algo required');
	}
}

# test for graphical interface
if ($opt_gui) {
	$opt_gui = test_gui();
}
elsif ($opt_tk) {
	$opt_gui = test_tk_gui();
}
elsif ($opt_curses) {
	$opt_gui = test_curses_gui();
}

if ( !$opt_gui ) {
	*display_status = sub { debug(@_) };
	*display_total  = sub { };
}

# phase 1 : get data and build structures
read_rpm_data( \%opt, \%Provides, \%Install_time, \%Files, \%Depends,
	\%Virtual );

# phase 2 : guess filter
# if a package is set, it will be first used, then it will use in order -all, then (guess*)
# (see filter sub)
display_status('2 : guess filter');
if (@opt_package) {
	@Liste_pac = @opt_package;
}
else {
	@Liste_pac = filter( \%opt, \%Provides );
}

# needed by access-time and install-time options
my $now = time;

# phase 3 : excluded and install-time filter
display_status('3 : excluded and install-time');
my @liste_pac2;
PACKAGE: foreach my $pac (@Liste_pac) {
	if ( exists $excluded{$pac} ) {
		display_status("skip $pac : excluded");
		next PACKAGE;
	}

	if ($opt_install_time) {
		my $diff = diff_date( $now, $Install_time{$pac} );
		if ( $opt_install_time > 0 ) {
			if ( $diff < $opt_install_time ) {
				display_status("skip $pac : too recent install ($diff days)");
				next PACKAGE;
			}
		}
		elsif ( $diff > -$opt_install_time ) {
			display_status("skip $pac : too old install ($diff days)");
			next PACKAGE;
		}
	}
	push @liste_pac2, $pac;
}

# note : access-time filter is a very slow method
# so we apply this filter after dependencies research
#  see below access_time_filter call

# we want the result sorted in alphabetic order
@Liste_pac = sort @liste_pac2;
display_total();

# phase 4 : solve dependencies
my @orphans =
  search_orphans( \%Provides, \%Files, \%Depends, \%Virtual, $now, \@Liste_pac,
	$Opt_access_time );

# phase 5 : display
if ($opt_gui) {
	insert_gui_orphans(@orphans);

	#build_summary(@orphans);
	display_status('display');

	# this will allow status update
	$Inloop = 1;
	MainLoop();
}
else {

	# just display @orphans
	my $txt = join "\n", @orphans;
	info($txt);
}

__END__

=head1 NAME

rpmorphan - find orphaned packages

=head1 DESCRIPTION

rpmorphan finds "orphaned" packages on your system. It determines which packages have no other 
packages depending on their installation, and shows you a list of these packages. 
It is clone of deborphan debian software for rpm packages.

It will try to help you to remove unused packages, for exemple :

- after a distribution upgrade

- when you want to suppress packages after some tests

=head1 SYNOPSIS

rpmorphan  [options] [targets]

options:

   -help                brief help message
   -man                 full documentation
   -V, --version        print version

   -verbose             verbose
   -dry-run             simulate package remove
   -fullalgo		force full algorythm
   -use-cache		use cache to avoid rpm query
   -clear-cache		remove cache file
   -gui			display the graphical interface
   -tk			display the tk graphical interface
   -curses 		display the curses graphical interface

   -exclude pac		exclude pac from results
   -install-time +/-d	apply on packages which are installed before (after) d days
   -access-time d	apply on packages which are not been accessed for d days (slow)

targets:

   -package pac		search if pac is an orphan package
   -all			apply on all packages
   -guess-perl		apply on perl packages
   -guess-python	apply on python packages
   -guess-pike		apply on pike packages
   -guess-ruby		apply on ruby packages
   -guess-common	apply on common packages
   -guess-data		apply on data packages
   -guess-doc		apply on documentation packages
   -guess-dev		apply on development packages
   -guess-lib		apply on library packages
   -guess-all		apply all -guess-* options (perl, python ...)
   -guess-custom regex	apply the given regex to filter to package's names to filter the output

keep file management

   -list-keep 		list permanent exclude list
   -zero-keep 		empty permanent exclude list
   -add-keep pac	add pac package to permanent exclude list
   -del-keep pac	remove pac package from permanent exclude list

=head1 REQUIRED ARGUMENTS

you should provide at least one target. this can be 

=over 8

=item B<-all>

all the installed rpm package

=item B<-package>

one or several explicit package

=item B<-guess-*>

pre-selected packages groups

=item B<-guess-custom>

give a filter to select the packages you want study

=back

=head1 OPTIONS

=over 8

=item B<-help>

Print a brief help message and exits.

=item B<-man>

Print the manual page and exits.

=item B<-version>

Print the program release and exit.

=item B<-verbose>

The program works and print debugging messages.

=item B<-dry-run>

this is a simulation mode : rpmorphan will show you what is
the result of package removing. The window's title is modified
to show this mode.

=item B<-use-cache>

the rpm query may be long (10 to 30 s). If you will run an rpmorphan tool
several time, this option will allow to gain a lot of time :
it save the rpm query on a file cache (first call), then
use this cache instead quering rpm (others calls).

=item B<-clear-cache>

to remove cache file. Can be used with -use-cache to write
a new cache.

=item B<-gui>

display a graphical interface which allow to show informations, remove packages
(an internal help is provided). This is currently the same as the -tk option

=item B<-tk>

display a tk graphical interface which allow to show informations, remove packages
(an internal help is provided). The Tk perl module is necessary to run the gui.

=item B<-curses>

display a curses graphical interface which allow to show informations, remove packages
(an internal help is provided). The Curses::UI perl module is necessary to run the gui.


=item B<-exclude>

this option will specify the packages to exclude from the output.
Can be used as '--exclude pac1 --exclude pac2'
or '--exclude "pac1, pac2"'

=item B<-install-time>

install-time is a filter on the period from the package installation date to now (in days).
if set positive, it only allow packages installed before x days.
if set negative, it only allow packages installed since x days.

=item B<-access-time>

access-time is designed to filter packages which have not been used since x days.

be careful : this option will slow the program

=item B<-fullalgo>

for a small list of packages, rpmorphan use a different quicker methode : rpm -e --test

this option can be used to force the use of the full algo

=item B<-package>

search if the given package(s) is(are) orphaned.
Can be used as '--package pac1 --package pac2'
or '--package "pac1, pac2"'

=item B<-all>

apply on all installed packages. The output should be interpreted.
For example lilo or grub are orphaned packages, but are necessary
to boot ...

the L<-install-time> and L<-access-time> options may be useful to filter the list

=item B<-guess-perl>

This option tries to find perl modules. It tries to match "^perl"

=item B<-guess-python>

This option tries to find python modules. It tries to match "^python"

=item B<-guess-pike>

This option tries to find pike modules. It tries to match "^pike"

=item B<-guess-ruby>

This option tries to find ruby modules. It tries to match "^ruby"

=item B<-guess-common>

This option tries to find common packages. It tries to match "-common$"

=item B<-guess-data>

This option tries to find data packages. It tries to match "-data$"

=item B<-guess-doc>

This option tries to find documentation packages. It tries to match "-doc$"

=item B<-guess-data>

This option tries to find data packages. It tries to match "-data$"

=item B<-guess-dev>

This option tries to find development packages. It tries to match "-devel$"

=item B<-guess-lib>

This option tries to find library packages. It tries to match "^lib"

=item B<-guess-all>

This is a short to tell : Try all of the above (perl, python ...)

=item B<-guess-custom>

this will allow you to specify your own filter. for exemple "^wh" 
will match whois, whatsnewfm ...

=item B<-list-keep>

list the permanent list of excluded packages and exit.

=item B<-zero-keep>

empty the permanent list of excluded packages and exit.

=item B<-add-keep>

add package(s) to the permanent list of excluded packages and exit.

Can be used as '--add-keep pac1 --add-keep pac2'
or '--add-keep "pac1, pac2"'

=item B<-del-keep>

remove package(s) from the permanent list of excluded packages and exit.

Can be used as '--add-keep pac1 --add-keep pac2'
or '--add-keep "pac1, pac2"'

=back

=head1 USAGE

rpmorphan can be useful after a distribution upgrade, to remove packages forgotten
by the upgrade tool. It is interesting to use the options "-all -install-time +xx'.

If you want to remove some recent tested packages, my advice is "-all -install-time -xx'.

if you just want to clean your disk, use '-all -access-time xxx'

use the -use-cache option, if you intend to run it several times

=head1 FILES

/var/lib/rpmorphan/keep : the permanent exclude list

/tmp/rpmorphan.cache : cache file to store rpm query. The cache
file is common to all rpmorphan tools

=head1 CONFIGURATION

the program can read rcfile if some exists.
it will load in order 

/etc/rpmorphanrc

~/.rpmorphanrc

.rpmorphanrc

In this file, 

# are comments, 

and parameters are stored in the following format :
parameter = value

example :

all = 1

curses = 1

=head1 DEPENDENCIES

rpmorphan uses standard perl module in console mode

if you want to use the Tk interface, you should install the Tk module

if you want to use the curses interface, you should install the Curses::UI module

=head1 BUGS AND LIMITATIONS

Virtuals packages are not well (for now) taken in account. 
Let's see an example : lilo and grub provide 'bootloader' virtual, which is 
necessary for system boot.
if the 2 are installed, they will be shown all 2 as orphans (but you can not remove 
the 2).
If you remove one of them, the other is now longer shown as orphan.

the software can only work with one version of each software : we only treat the first version seen

=head1 INCOMPATIBILITIES

not known

=head1 DIAGNOSTICS

to be written

=head1 NOTES

this program can be used as "normal" user to show orphans,
but you need to run it as supersuser (root) to remove packages
or apply changes in the permanent exclude list

access-time and install-time options are "new" features, not available
in deborphan tool

=head1 SEE ALSO

=for man
\fIrpm\fR\|(1) for rpm call
.PP
\fIrpmusage\fR\|(1) for rpmusage use

=for html
<a href="rpmusage.1.html">rpmusage(1)</a>

=head1 EXIT STATUS

should be allways 0

=head1 LICENSE AND COPYRIGHT

Copyright (C) 2006 by Eric 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.

=head1 AUTHOR

Eric Gerbier

you can report any bug or suggest to gerbier@users.sourceforge.net

=cut
