diff options
Diffstat (limited to 'rpmorphan-lib.pl')
-rwxr-xr-x | rpmorphan-lib.pl | 792 |
1 files changed, 792 insertions, 0 deletions
diff --git a/rpmorphan-lib.pl b/rpmorphan-lib.pl new file mode 100755 index 0000000..5eacbcc --- /dev/null +++ b/rpmorphan-lib.pl @@ -0,0 +1,792 @@ +#!/usr/bin/perl +############################################################################### +# rpmorphan-lib.pl +# +# Copyright (C) 2006 by Eric Gerbier +# Bug reports to: gerbier@users.sourceforge.net +# $Id: rpmorphan-1.11 | rpmorphan-lib.pl | Wed Aug 1 09:36:43 2012 +0200 | 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. +# +# 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 Data::Dumper; # debug +use File::stat; # get_last_access + +## no critic (RequireCheckingReturnValueOfEval) + +# the code should use no "print" calls +# but use instead debug, warning, info calls +############################################################################### +sub nodebug { + return; +} +############################################################################### +sub backend_debug { + my $text = $_[0]; + print "debug $text\n"; + return; +} +############################################################################### +# change debug subroutine +# this way seems better than 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 critic ( NoWarnings ); + no warnings 'redefine'; + ## use critic; + + if ($verbose) { + *debug = \&backend_debug; + } + else { + *debug = \&nodebug; + } + + 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($) { + my $version = shift @_; + info("$PROGRAM_NAME version $version"); + return; +} +######################################################### +# used to check on option +sub is_set($$) { + my $rh_opt = shift @_; # hash of program arguments + my $key = shift @_; # name of desired option + + #debug("is_set $key"); + my $r_value = $rh_opt->{$key}; + return ${$r_value}; +} +######################################################### +sub is_verbose($) { + my $rh_opt = shift @_; # hash of program arguments + + return is_set( $rh_opt, 'verbose' ); +} +######################################################### +# apply a filter on package list according program options +sub rpmfilter($$) { + 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 + ## no critic(ProhibitParensWithBuiltins,ProhibitMagicNumbers) + 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 ); +} +######################################################### +# depending the cache option, return a command to execute +# - as an rpm query (piped) +# - as a cache file to open +sub init_cache($) { + my $rh_opt = shift @_; # hash of program arguments + + # 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 $suggests = ( is_set( $rh_opt, 'suggests' ) ) ? '[%{SUGGESTS},]' : q{}; + + my $rpm_cmd = +"rpm -qa --queryformat '%{NAME};[%{REQUIRENAME},]$suggests;[%{PROVIDES},];[%{FILENAMES},];%{INSTALLTIME}\n' 2>/dev/null"; + my $cache_file = '/tmp/rpmorphan.cache'; + my $fh_cache; + my $cmd; + + 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 + ## no critic (RequireBriefOpen) + if ( open $fh_cache, '>', $cache_file ) { + display_status("create cache file $cache_file"); + } + else { + warning("can not create cache file $cache_file : $ERRNO"); + } + } + } + else { + + # output may be long, so we use a pipe to avoid to store a big array + $cmd = "$rpm_cmd |"; + display_status('read rpm data'); + + unlink $cache_file if ( -f $cache_file ); + } + + return ( $cmd, $fh_cache ); +} +######################################################### +## no critic (ProhibitManyArgs) +sub analyse_rpm_info($$$$$$$$$$) { + my $name = shift @_; # current package name + my $ra_prov = shift @_; # data from database on name + my $ra_req = shift @_; # idem + my $ra_files = shift @_; # idem + my $rh_objects = shift @_; + my $rh_provides = shift @_; + my $rh_files = shift @_; + my $rh_depends = shift @_; + my $rh_virtual = shift @_; + my $rh_requires = shift @_; + + ## use critic; + + # 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"); + } + + VIRTUAL: foreach my $p ( @{$ra_prov}, @{$ra_files} ) { + + # do not add files + #next VIRTUAL if ( $p =~ m!^/! ); + + # some bad package may provide more than on time the same object + if ( ( exists $rh_objects->{$p} ) + && ( $rh_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}{ $rh_objects->{$p} } = 1; + } + + # add new virtual + $rh_virtual->{$p}{$name} = 1; + } + else { + + # keep memory of seen "provided" + $rh_objects->{$p} = $name; + } + } + + # $name package provide @prov + # file are also included in "provide" + push @{ $rh_provides->{$name} }, @{$ra_prov}, @{$ra_files}; + + # list are necessary for access-time option + push @{ $rh_files->{$name} }, @{$ra_files}; + + # this will be helpfull when recursive remove package + push @{ $rh_requires->{$name} }, @{$ra_req}; + + # build a hash for dependencies + foreach my $require ( @{$ra_req} ) { + + # we have to suppress auto-depends (ex : ark package) + my $flag_auto = 0; + PROVIDE: foreach my $p ( @{$ra_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; + } + return; +} +######################################################### +# read rpm information about all installed packages +# can be from database, or from rpmorphan cache +sub read_rpm_data_base($$$$$$$) { + 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 @_; + my $rh_requires = shift @_; + + display_status('read rpm data using base RPM'); + my ( $cmd, $fh_cache ) = init_cache($rh_opt); + + # because we can open a pipe or a cache, it is not possible to use + # the 3 arg form of open + ## no critic (ProhibitTwoArgOpen,RequireBriefOpen); + my $fh; + if ( !open $fh, $cmd ) { + + # no critic; + die "can not open $cmd : $ERRNO\n"; + ## use critic + } + debug('1 : analysis'); + my %objects; + while (<$fh>) { + + # write cache + print {$fh_cache} $_ if ($fh_cache); + + my ( $name, $req, $prov, $files, $install_time ) = split /;/, $_; + + # install time are necessary for install-time option + $rh_install_time->{$name} = $install_time; + + # see rpm query format in init_cache + my $delim = q{,}; + my @prov = split /$delim/, $prov; + my @req = split /$delim/, $req; + my @files = split /$delim/, $files; + + analyse_rpm_info( + $name, \@prov, \@req, \@files, + \%objects, $rh_provides, $rh_files, $rh_depends, + $rh_virtual, $rh_requires + ); + + } + close $fh or warning("problem to close rpm command : $ERRNO"); + + # close cache if necessary + if ($fh_cache) { + close $fh_cache or warning("problem to close cache file : $ERRNO"); + } + return; +} +######################################################### +# read database info by use of RPM2 module +sub read_rpm_data_rpm2($$$$$$$) { + 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 @_; + my $rh_requires = shift @_; + + # cache ? + # acces to data by rpm2 should be fast, + # so do not need cache + # and init_cache works with a command to exec + # not with a perl module + + display_status('read rpm data using RPM2'); + import RPM2; + my $db = RPM2->open_rpm_db(); + + my $flag_suggests = is_set( $rh_opt, 'suggests' ); + + debug('1 : analysis'); + my %objects; + + my $i = $db->find_all_iter(); + while ( my $pkg = $i->next ) { + + my $name = $pkg->name; + my $install_time = $pkg->installtime; + $rh_install_time->{$name} = $install_time; + + my @req = $pkg->requires; + my @prov = $pkg->provides; + my @files = $pkg->files; + + if ($flag_suggests) { + my @suggests = $pkg->tag('SUGGESTS'); + + #debug("suggests for $name : " . join ' ', @suggests); + push @req, @suggests; + } + + analyse_rpm_info( + $name, \@prov, \@req, \@files, + \%objects, $rh_provides, $rh_files, $rh_depends, + $rh_virtual, $rh_requires + ); + } + return; +} +######################################################### +# URPM return dependencies as perl[ = 5.8] +# we have to suppress the version and only keep the package +sub clean_rel($) { + my $ra = shift @_; + + foreach my $elem ( @{$ra} ) { + $elem =~ s/\[.*\]//; + } + return; +} +######################################################### +# read database info by use of URPM module +sub read_rpm_data_urpm($$$$$$$) { + 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 @_; + my $rh_requires = shift @_; + + # cache ? + # acces to data by rpm2 should be fast, + # so do not need cache + # and init_cache works with a command to exec + # not with a perl module + + display_status('read rpm data using URPM'); + import URPM; + my $db = URPM::DB::open(); + debug('1 : analysis'); + + my $flag_suggests = is_set( $rh_opt, 'suggests' ); + + my %objects; + $db->traverse( + sub { + my ($package) = @_; # this is a URPM::Package object + my $name = $package->name; + my $installtime = $package->queryformat('%{INSTALLTIME}'); + $rh_install_time->{$name} = $installtime; + my @req = $package->requires(); + clean_rel( \@req ); + my @prov = $package->provides(); + clean_rel( \@prov ); + my @files = $package->files(); + + if ($flag_suggests) { + my $suggests = $package->queryformat('[%{SUGGESTS},]'); + my @suggests = split /,/, $suggests; + + #debug("suggests for $name : " . join ' ', @suggests); + clean_rel( \@suggests ); + push @req, @suggests; + } + + analyse_rpm_info( + $name, \@prov, \@req, \@files, + \%objects, $rh_provides, $rh_files, $rh_depends, + $rh_virtual, $rh_requires + ); + } + ); + + return; +} +######################################################### +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 @_; + my $rh_requires = shift @_; + + # empty all structures + %{$rh_provides} = (); + %{$rh_install_time} = (); + %{$rh_files} = (); + %{$rh_depends} = (); + %{$rh_virtual} = (); + %{$rh_requires} = (); + + my %code = ( + 'URPM' => \&read_rpm_data_urpm, + 'RPM2' => \&read_rpm_data_rpm2, + 'basic' => \&read_rpm_data_base, + ); + my @def_list = ( 'URPM', 'RPM2', 'basic' ); + my @list; + if ( exists $ENV{'RPMORPHAN_METHOD'} ) { + my $method = $ENV{'RPMORPHAN_METHOD'}; + + # should be 'URPM', 'RPM2' or 'basic' + if ( exists $code{$method} ) { + push @list, $method; + + # for security : basic will allways work + push @list, 'basic'; + } + else { + warning("unknown method $method, use default"); + @list = @def_list; + } + } + else { + + # default list (ordered) of perl packages to test + @list = @def_list; + } + my $ok = 0; + foreach my $method (@list) { + debug("try $method"); + eval { require $method . '.pm'; }; + if ($EVAL_ERROR) { + debug("can not use $method"); + } + else { + $ok = 1; + *read_rpm_data_m = $code{$method}; + read_rpm_data_m( $rh_opt, $rh_provides, $rh_install_time, $rh_files, + $rh_depends, $rh_virtual, $rh_requires ); + last; + } + } + if ( !$ok ) { + + # if nothing is working, use default basic method + read_rpm_data_base( $rh_opt, $rh_provides, $rh_install_time, $rh_files, + $rh_depends, $rh_virtual, $rh_requires ); + } + return; +} +## use critic +######################################################### +sub read_one_rc($$$) { + my $rh_list = shift @_; # list of available parameters + my $fh_rc = shift @_; + my $rcfile = shift @_; + + # 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} ) { + + # the last line wins + if ( ref( $rh_list->{$key} ) eq 'ARRAY' ) { + @{ $rh_list->{$key} } = get_from_command_line($value); + } + else { + ${ $rh_list->{$key} } = $value; + } + + # special case : verbose will modify immediately behavior + init_debug($value) if ( $key eq 'verbose' ); + + debug( +"rcfile ($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++; + } + + 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"); + if ( open my $fh_rc, '<', $rcfile ) { + read_one_rc( $rh_list, $fh_rc, $rcfile ); + close $fh_rc + or warning("problem to close rc file $rcfile :$ERRNO"); + } + else { + warning("can not open rcfile $rcfile : $ERRNO"); + } + } + 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{,}; + ## no critic (ProhibitParensWithBuiltins); + return split /$comma/, join( $comma, @arg ); + ## use critic; +} +######################################################### +sub is_remove_allowed($) { + my $opt_dry_run = shift @_; + + return ( ( $EFFECTIVE_USER_ID == 0 ) && ( !$opt_dry_run ) ); +} +######################################################### +# analyse command line options for guess +sub ana_guess($) { + my $rh_opt = shift @_; + + debug('ana_guess'); + + my $true = 1; + + # guess-all force all others + if ( is_set( $rh_opt, 'guess-all' ) ) { + $rh_opt->{'guess-perl'} = \$true; + $rh_opt->{'guess-python'} = \$true; + $rh_opt->{'guess-pike'} = \$true; + $rh_opt->{'guess-ruby'} = \$true; + $rh_opt->{'guess-common'} = \$true; + $rh_opt->{'guess-data'} = \$true; + $rh_opt->{'guess-doc'} = \$true; + $rh_opt->{'guess-dev'} = \$true; + $rh_opt->{'guess-lib'} = \$true; + } + + my $is_guess = + is_set( $rh_opt, 'guess-perl' ) + || is_set( $rh_opt, 'guess-python' ) + || is_set( $rh_opt, 'guess-pike' ) + || is_set( $rh_opt, 'guess-ruby' ) + || is_set( $rh_opt, 'guess-common' ) + || is_set( $rh_opt, 'guess-data' ) + || is_set( $rh_opt, 'guess-doc' ) + || is_set( $rh_opt, 'guess-dev' ) + || is_set( $rh_opt, 'guess-lib' ) + || is_set( $rh_opt, 'guess-custom' ); + + # test if a target is set + if ( ( !@{ $rh_opt->{'package'} } ) + && ( !is_set( $rh_opt, 'all' ) ) + && ( !$is_guess ) ) + { + + # default behavior if no targets selected + debug('set target to guess-lib (default)'); + $rh_opt->{'guess-lib'} = \$true; + } + return; +} +######################################################### +# parse command line exclude option +sub build_excluded($$) { + my $rh_opt = shift @_; + my $rh_excluded = shift @_; + + debug('build_excluded'); + if ( $rh_opt->{'exclude'} ) { + + # allow comma separated options on tags option + # and build a hash for faster access + my @liste_ex = get_from_command_line( @{ $rh_opt->{'exclude'} } ); + foreach my $ex (@liste_ex) { + $rh_excluded->{$ex} = 1; + debug("build_excluded : exclude $ex"); + } + } + + # to be passed to load_data; + # be carefull : we use here a new key : excluded , not exclude (command line) + $rh_opt->{'excluded'} = $rh_excluded; + return; +} +######################################################### +sub get_package_info($) { + my $pac = shift @_; + + my $cmd = "rpm -qil $pac"; + ## no critic ( ProhibitBacktickOperators ); + my @res = `$cmd`; + ## use critic + chomp @res; + + return @res; +} +######################################################### +sub get_package_summary($) { + my $pac = shift @_; + + my $cmd = "rpm -q --queryformat '%{SUMMARY}' $pac"; + ## no critic ( ProhibitBacktickOperators ); + my $res = `$cmd`; + ## use critic + + return $res; +} +######################################################### +# return true is rpm allow SUGGEST tags +sub is_suggests() { + + my $cmd = 'rpm -q --querytags '; + ## no critic ( ProhibitBacktickOperators ); + my @res = `$cmd`; + ## use critic + foreach my $tag (@res) { + chomp $tag; + if ( $tag =~ m/^SUGGESTS/ ) { + return 1; + } + } + return 0; +} +######################################################### + +1; |