urpmi library (perl module). contains code for managing media and packages.

1 files changed, 836 insertions, 0 deletions

diff --git a/urpm.pm b/urpm.pm
new file mode 100644
index 00000000..cf7cf3e6
--- /dev/null
+++ b/urpm.pm
@@ -0,0 +1,836 @@
+package urpm;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+$VERSION = '1.30';
+
+=head1 NAME
+
+urpm - Mandrake perl tools to handle urpmi database
+
+=head1 SYNOPSYS
+
+    require urpm;
+
+    my $urpm = new urpm;
+
+    $urpm->read_depslist();
+    $urpm->read_provides();
+    $urpm->read_compss();
+    $urpm->read_config();
+
+=head1 DESCRIPTION
+
+C<urpm> is used by urpmi executable to manipulate packages and mediums
+on a Linux-Mandrake distribution.
+
+=head1 SEE ALSO
+
+rpmtools package is used to manipulate at a lower level hdlist and rpm
+files.
+
+=head1 COPYRIGHT
+
+Copyright (C) 2000 MandrakeSoft <fpons@mandrakesoft.com>
+
+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, 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+=cut
+
+use rpmtools;
+
+#- create a new urpm object.
+sub new {
+    my ($class) = @_;
+    bless {
+	   config     => "/etc/urpmi/urpmi.cfg",
+	   depslist   => "/var/lib/urpmi/depslist.ordered",
+	   provides   => "/var/lib/urpmi/provides",
+	   compss     => "/var/lib/urpmi/compss",
+	   statedir   => "/var/lib/urpmi",
+	   media      => undef,
+	   params     => new rpmtools,
+
+	   error      => sub { printf STDERR "%s\n", $_[0] },
+	   log        => sub { printf STDERR "%s\n", $_[0] },
+	  }, $class;
+}
+
+#- quoting/unquoting a string that may be containing space chars.
+sub quotespace { local $_ = $_[0]; s/(\s)/\\$1/g; $_ }
+sub unquotespace { local $_ = $_[0]; s/\\(\s)/$1/g; $_ }
+
+#- read /etc/urpmi/urpmi.cfg as config file, keep compability with older
+#- configuration file by examining if one entry is of the form
+#-   <name> <url> {
+#-      ...
+#-   }
+#- else only this form is used
+#-   <name> <url>
+#-   <name> <ftp_url> with <relative_path_hdlist>
+sub read_config {
+    my ($urpm) = @_;
+
+    #- keep in mind if it has been called before.
+    $urpm->{media} ||= [];
+
+    #- check urpmi.cfg content, if the file is old keep track
+    #- of old format used.
+    local (*F, $_);
+    open F, $urpm->{config}; #- no filename can be allowed on some case
+    while (<F>) {
+	chomp; s/#.*$//; s/\s*$//;
+	/^\s*(.*?[^\\])\s+(?:(.*?[^\\])\s+)?\{$/ and do { #- urpmi.cfg format extention
+	    my $medium = { name => unquotespace($1), clear_url => unquotespace($2) };
+	    while (<F>) {
+		chomp; s/#.*$//; s/\s*$//;
+		/^\s*hdlist\s*:\s*(.*)$/ and $medium->{hdlist} = $1, next;
+		/^\s*with_hdlist\s*:\s*(.*)$/ and $medium->{with_hdlist} = $1, next;
+		/^\s*list\s*:\s*(.*)$/ and $medium->{list} = $1, next;
+		/^\s*removable\s*:\s*(.*)$/ and $medium->{removable} = $1, next;
+		/^\s*ignore\s*$/ and $medium->{ignore} = 1, next;
+		/^\s*modified\s*$/ and $medium->{modified} = 1, next;
+		/^\s*}$/ and last;
+		/^\s*$/ or $urpm->{error}("syntax error at line $. in $urpm->{config}");
+	    }
+	    $urpm->probe_medium($medium);
+	    push @{$urpm->{media}}, $medium;
+	    next; };
+	/^\s*(.*?[^\\])\s+(.*?[^\\])\s+with\s+(.*)$/ and do { #- urpmi.cfg old format for ftp
+	    my $medium = { name => unquotespace($1), clear_url => unquotespace($2), with_hdlist => unquotespace($3) };
+	    $urpm->probe_medium($medium);
+	    push @{$urpm->{media}}, $medium;
+	    next; };
+	/^\s+(.*?[^\\])\s+(?:(.*?[^\\])\s*)$/ and do { #- urpmi.cfg old format (assume hdlist.<name>.cz2?)
+	    my $medium = { name => unquotespace($1), clear_url => unquotespace($2) };
+	    $urpm->probe_medium($medium);
+	    push @{$urpm->{media}}, $medium;
+	    next; };
+	/^\s*$/ or $urpm->{error}("syntax error at line $. in [$urpm->{config}]");
+    }
+    close F;
+
+    #- keep in mind when an hdlist/list file is used, really usefull for
+    #- the next probe.
+    my (%hdlists, %lists);
+    foreach (@{$urpm->{media}}) {
+	exists $hdlists{$_->{hdlist}} and
+	  $_->{ignore} = 1, $urpm->{error}("medium \"$_->{name}\" try to use an already used hdlist, medium ignored");
+	$_->{ignore} or $hdlists{$_->{hdlist}} = undef;
+	exists $lists{$_->{list}} and
+	  $_->{ignore} = 1, $urpm->{error}("medium \"$_->{name}\" try to use an already used list, medium ignored");
+	$_->{ignore} or $lists{$_->{list}} = undef;
+    }
+
+    #- urpmi.cfg if old is not enough to known the various media, track
+    #- directly into /var/lib/urpmi,
+    foreach (glob("$urpm->{statedir}/hdlist.*")) {
+	if (/\/hdlist\.((.*)\.cz2?)$/) {
+	    #- check if it has already been detected above.
+	    exists $hdlists{"hdlist.$1"} and next;
+
+	    #- if not this is a new media to take care if
+	    #- there is a list file.
+	    if (-s "$urpm->{statedir}/list.$2") {
+		if (exists $lists{"list.$2"}) {
+		    $urpm->{error}("unable to take medium \"$2\" into account as list file is already used by another medium");
+		} else {
+		    my $medium;
+		    foreach (@{$urpm->{media}}) {
+			$_->{ignore} and next;
+			$_->{name} eq $2 and $medium = $_, last;
+		    }
+		    $medium and $urpm->{error}("unable to use name \"$2\" for unamed medium because it is already used"), next;
+
+		    $medium = { name => $2, hdlist => "hdlist.$1", list => "list.$2" };
+		    $urpm->probe_medium($medium);
+		    push @{$urpm->{media}}, $medium;
+		}
+	    } else {
+		$urpm->{error}("unable to take medium \"$2\" into account as no list file [$urpm->{statedir}/list.$2] exists");
+	    }
+	} else {
+	    $urpm->{error}("unable to determine medium of this hdlist file [$_]");
+	}
+    }
+
+    #- check the presence of hdlist file and list file if necessary.
+    #- TODO?: degraded mode is possible with a list file but no hdlist, the medium
+    #- is no longer updatable nor removable TODO
+    foreach (@{$urpm->{media}}) {
+	$_->{ignore} and next;
+	-r "$urpm->{statedir}/$_->{hdlist}" or
+	  $_->{ignore} = 1, $urpm->{error}("unable to access hdlist file of \"$_->{name}\", medium ignored");
+	$_->{list} && -r "$urpm->{statedir}/$_->{list}" or
+	  $_->{ignore} = 1, $urpm->{error}("unable to access list file of \"$_->{name}\", medium ignored");
+    }
+}
+
+#- probe medium to be used, take old medium into account too.
+sub probe_medium {
+    my ($urpm, $medium) = @_;
+
+    unless ($medium->{ignore} || $medium->{hdlist}) {
+	$medium->{hdlist} = "hdlist.$medium->{name}.cz";
+	-e "$urpm->{statedir}/$medium->{hdlist}" or $medium->{hdlist} = "hdlist.$medium->{name}.cz2";
+	-e "$urpm->{statedir}/$medium->{hdlist}" or
+	  $medium->{ignore} = 1, $urpm->{error}("unable to find hdlist file for \"$medium->{name}\", medium ignored");
+    }
+    unless ($medium->{ignore} || $medium->{list}) {
+	$medium->{list} = "list.$1";
+	-e "$urpm->{statedir}/$medium->{list}" or
+	  $medium->{ignore} = 1, $urpm->{error}("unable to find list file for \"$medium->{name}\", medium ignored");
+    }
+
+    #- there is a little more to do at this point as url is not known, inspect directly list file for it.
+    unless ($medium->{ignore} || $medium->{url} || $medium->{clear_url}) {
+	my %probe;
+	local (*F, $_);
+	open F, "$urpm->{statedir}/$medium->{list}";
+	while (<F>) {
+	    /^(.*)\/[^\/]*/ and $probe{$1} = undef;
+	}
+	close F;
+	foreach (sort { length($a) <=> length($b) } keys %probe) {
+	    if ($medium->{url}) {
+		$medium->{url} eq substr($_, 0, length($medium->{url})) or
+		  $medium->{ignore} = 1, $urpm->{error}("incoherent list file for \"$medium->{name}\", medium ignored"), last;
+	    } else {
+		$medium->{url} = $_;
+	    }
+	}
+	$medium->{url} or
+	  $medium->{ignore} = 1, $urpm->{error}("unable to inspect list file for \"$medium->{name}\", medium ignored");
+    }
+    $medium->{url} ||= $medium->{clear_url};
+}
+
+#- write back urpmi.cfg code to allow modification of medium listed.
+sub write_config {
+    my ($urpm) = @_;
+
+    #- avoid trashing exiting configuration in this case.
+    $urpm->{media} or return;
+
+    local *F;
+    open F, ">$urpm->{config}" or $urpm->{error}("unable to write config file [$urpm->{config}]");
+    foreach my $medium (@{$urpm->{media}}) {
+	printf F "%s %s {\n", quotespace($medium->{name}), quotespace($medium->{clear_url});
+	foreach (qw(hdlist with_hdlist list removable)) {
+	    $medium->{$_} and printf F "  %s: %s\n", $_, $medium->{$_};
+	}
+	foreach (qw(ignore modified)) {
+	    $medium->{$_} and printf F "  %s\n", $_;
+	}
+	printf F "}\n\n";
+    }
+    close F;
+    $urpm->{log}("write config file [$urpm->{config}]");
+}
+
+#- add a new medium, sync the config file accordingly.
+sub add_medium {
+    my ($urpm, $name, $url, $with_hdlist) = @_;
+
+    #- make sure configuration has been read.
+    $urpm->{media} or $urpm->read_config();
+
+    #- if a medium with that name has already been found
+    #- we have to exit now
+    my ($medium);
+    foreach (@{$urpm->{media}}) {
+	$_->{ignore} and next;
+	$_->{name} eq $2 and $medium = $_;
+    }
+    $medium and $urpm->{error}("medium \"$medium\" already exists"), return;
+
+    #- creating the medium info.
+    $medium = { name     => $name,
+		url      => $url,
+		hdlist   => "hdlist.$name.cz",
+		list     => "list.$name",
+		modified => 1,
+	      };
+
+    #- check to see if the medium is using file protocol or removable medium.
+    if (my ($prefix, $dir) = $url =~ /^(removable_.*?|file):\/(.*)/) {
+	#- the directory given does not exist or may be accessible
+	#- by mounting some other. try to figure out these directory and
+	#- mount everything necessary.
+	$urpm->try_mounting($dir);
+
+	#- check if directory is somewhat normalized so that we can get back hdlist,
+	#- check it that case if depslist, compss and provides file are also
+	#- provided.
+	if (!($with_hdlist && -e "$dir/$with_hdlist") && $dir =~ /RPMS([^\/]*)\/*$/) {
+	    foreach my $rdir (qw(Mandrake/base ../Mandrake/base ..)) {
+		-e "$dir/$_/hdlist$1.cz" and $with_hdlist = "$_/hdlist$1.cz", last;
+		-e "$dir/$_/hdlist$1.cz2" and $with_hdlist = "$_/hdlist$1.cz2", last;
+	    }
+	}
+
+	#- add some more flags for this type of medium.
+	$medium->{clear_url} = $url;
+	$medium->{removable} = $url =~ /^removable_([^_:]*)(?:_[^:]*)?:/ && "/dev/$1";
+    }
+
+    #- all flags once everything has been computed.
+    $with_hdlist and $medium->{with_hdlist} = $with_hdlist;
+
+    #- create an entry in media list.
+    push @{$urpm->{media}}, $medium;
+
+    #- keep in mind the database has been modified and base files need to be updated.
+    $urpm->{modified} = 1;
+}
+
+sub remove_media {
+    my $urpm = shift;
+    my %media; @media{@_} = undef;
+    my @result;
+
+    foreach (@{$urpm->{media}}) {
+	if (exists $media{$_->{name}}) {
+	    $media{$_->{name}} = 1; #- keep it mind this one has been removed
+
+	    #- remove file associated with this medium.
+	    #- this is the hdlist and the list files.
+	    unlink "$urpm->{statedir}/$_->{hdlist}";
+	    unlink "$urpm->{statedir}/$_->{list}";
+	} else {
+	    push @result, $_; #- not removed so keep it
+	}
+    }
+
+    #- check if some arguments does not correspond to medium name.
+    foreach (keys %media) {
+	if ($media{$_}) {
+	    #- when a medium is removed, depslist and others need to be recomputed.
+	    $urpm->{modified} = 1;
+	} else {
+	    $urpm->{error}("trying to remove inexistant medium \"$_\"");
+	}
+    }
+
+    #- special case if there is no more media registered.
+    #- there is no need to recompute the hdlist and the files
+    #- can be safely removed.
+    if ($urpm->{modified} && @result == 0) {
+	unlink $urpm->{depslist};
+	unlink $urpm->{provides};
+	unlink $urpm->{compss};
+    }
+
+    #- restore newer media list.
+    $urpm->{media} = \@result;
+}
+
+sub select_media {
+    my $urpm = shift;
+    my %media; @media{@_} = undef;
+
+    foreach (@{$urpm->{media}}) {
+	if (exists $media{$_->{name}}) {
+	    $media{$_->{name}} = 1; #- keep it mind this one has been selected.
+
+	    #- select medium by setting modified flags, do not check ignore.
+	    $_->{modified} = 1;
+	}
+    }
+
+    #- check if some arguments does not correspond to medium name.
+    foreach (keys %media) {
+	unless ($media{$_}) {
+	    $urpm->{error}("trying to select inexistant medium \"$_\"");
+	}
+    }
+}
+
+#- update urpmi database regarding the current configuration.
+#- take care of modification and try some trick to bypass
+#- computational of base files.
+sub update_media {
+    my ($urpm, %options) = @_; #- do not trust existing hdlist and try to recompute them.
+
+    #- avoid trashing existing configuration in this case.
+    $urpm->{media} or return;
+
+    #- examine each medium to see if one of them need to be updated.
+    #- if this is the case and if not forced, try to use a pre-calculated
+    #- hdlist file else build it from rpms files.
+    foreach my $medium (@{$urpm->{media}}) {
+	#- take care of modified medium only or all if all have to be recomputed.
+	$medium->{ignore} and next;
+	$options{all} || $medium->{modified} or next;
+
+	#- list of rpm files for this medium, only available for local medium where
+	#- the source hdlist is not used (use force).
+	my ($prefix, $dir, $error, @files);
+
+	#- check to see if the medium is using file protocol or removable medium.
+	if (($prefix, $dir) = $medium->{url} =~ /^(removable_.*?|file):\/(.*)/) {
+	    #- the directory given does not exist and may be accessible
+	    #- by mounting some other. try to figure out these directory and
+	    #- mount everything necessary.
+	    $urpm->try_mounting($dir);
+
+	    #- if the source hdlist is present and we are not forcing using rpms file
+	    if (!$options{force} && $medium->{with_hdlist} && -e "$dir/$medium->{with_hdlist}") {
+		system("cp", "-f", "$dir/$medium->{with_hdlist}", "$urpm->{statedir}/.$medium->{hdlist}");
+		-s "$urpm->{statedir}/.$medium->{hdlist}"
+		  or $error = 1, $urpm->{error}("copy of [$dir/$medium->{with_hdlist}] failed");
+	    } else {
+		#- try to find rpm files, use recursive method, added additional
+		#- / after dir to make sure it will be taken into account if this
+		#- is a symlink to a directory.
+		@files = split "\n", `find '$dir/' -name "*.rpm" -print`;
+
+		#- check files contains something good!
+		if (@files > 0) {
+		    #- we need to rebuild from rpm files the hdlist.
+		    $urpm->{params}->build_hdlist("$urpm->{statedir}/.$medium->{hdlist}", @files);
+		} else {
+		    $error = 1;
+		    $urpm->{error}("no rpm files found from [$dir/]");
+		}
+	    }
+	} else {
+	    system("wget", "-O", "$urpm->{statedir}/.$medium->{hdlist}", "$medium->{url}/$medium->{with_hdlist}");
+	    $? == 0 or $error = 1, $urpm->{error}("wget of [<source_url>/$medium->{with_hdlist}] failed (maybe wget is missing?)");
+	}
+
+	#- build list file according to hdlist used.
+	#- make sure group and other does not have any access to this file.
+	unless ($error) {
+	    local *LIST;
+	    my $mask = umask 077;
+	    open LIST, ">$urpm->{statedir}/.$medium->{list}"
+	      or $error = 1, $urpm->{error}("unable to write list file of \"$medium->{name}\"");
+	    umask $mask;
+	    if (@files) {
+		foreach (@files) {
+		    print LIST "$prefix:/$_\n";
+		}
+	    } else {
+		local (*F, $_);
+		open F, "parsehdlist '$urpm->{statedir}/.$medium->{hdlist}' |";
+		while (<F>) {
+		    print LIST "$medium->{url}/$_";
+		}
+		close F;
+	    }
+	    close LIST;
+
+	    #- check if at least something has been written into list file.
+	    -s "$urpm->{statedir}/.$medium->{list}"
+	      or $error = 1, $urpm->{error}("nothing written in list file for \"$medium->{name}\"");
+	}
+
+	if ($error) {
+	    #- an error has occured for updating the medium, we have to remove tempory files.
+	    unlink "$urpm->{statedir}/.$medium->{hdlist}";
+	    unlink "$urpm->{statedir}/.$medium->{list}";
+	} else {
+	    #- make sure to rebuild base files and clean medium modified state.
+	    $medium->{modified} = 0;
+	    $urpm->{modified} = 1;
+
+	    #- but use newly created file.
+	    unlink "$urpm->{statedir}/$medium->{hdlist}";
+	    unlink "$urpm->{statedir}/$medium->{list}";
+	    rename "$urpm->{statedir}/.$medium->{hdlist}", "$urpm->{statedir}/$medium->{hdlist}";
+	    rename "$urpm->{statedir}/.$medium->{list}", "$urpm->{statedir}/$medium->{list}";
+	}
+    }
+
+    #- build base files (depslist.ordered, provides, compss) according to modified global status.
+    if ($urpm->{modified}) {
+	#- special case if there is no more media registered.
+	#- there is no need to recompute the hdlist and the files
+	#- can be safely removed.
+	if (@{$urpm->{media}} == 0) {
+	    unlink $urpm->{depslist};
+	    unlink $urpm->{provides};
+	    unlink $urpm->{compss};
+
+	    $urpm->{modified} = 0;
+	}
+
+	if (!$options{force} && @{$urpm->{media}} == 1 && $urpm->{media}[0]{with_hdlist}) {
+	    #- this is a special mode where is only one hdlist using a source hdlist, in such
+	    #- case we are searching for source depslist, provides and compss files.
+	    #- if they are not found or if force is used, an error message is printed and
+	    #- we continue using computed results.
+	    my $medium = $urpm->{media}[0];
+	    my $basedir = $medium->{with_hdlist} =~ /^(.*)\/[^\/]*$/ && $1;
+
+	    foreach my $target ($urpm->{depslist}, $urpm->{provides}, $urpm->{compss}, 'END') {
+		$target eq 'END' and $urpm->{modified} = 0, last; #- assume everything is ok.
+		my $basename = $target =~ /^.*\/([^\/]*)$/ && $1;
+
+		if (my ($prefix, $dir) = $medium->{url} =~ /^(removable_.*?|file):\/(.*)/) {
+		    #- the directory should be existing in any cases or this is an error
+		    #- so there is no need of trying to mount it.
+		    if (-e "$dir/$basedir/$basename") {
+			system("cp", "-f", "$dir/$basedir/$basename", $target);
+			$? == 0 or $urpm->{error}("unable to copy source of [$target] from [$dir/$basedir/$basename]"), last;
+		    } else {
+			$urpm->{error}("source of [$target] not found as [$dir/$basedir/$basename]"), last;
+		    }
+		} else {
+		    #- we have to use wget here instead.
+		    system("wget", "-O", $target, "$medium->{url}/$basedir/$basename");
+		    $? == 0 or $urpm->{error}("wget of [$medium->{url}/$basedir/$basename] failed (maybe wget is missing?)"), last;
+		}
+	    }
+	}
+
+	if ($urpm->{modified}) {
+	    #- cleaning.
+	    $urpm->{params}->clean();
+
+	    #- if a provides exists, try to use it to speed up process
+	    #- but this is not mandatory here.
+	    -r $urpm->{provides} and $urpm->read_provides();
+
+	    #- compute depslist after reading each hdlist of medium
+	    #- in the right order.
+	    foreach my $medium (@{$urpm->{media}}) {
+		$medium->{ignore} and next;
+		$urpm->{params}->read_hdlists("$urpm->{statedir}/$medium->{hdlist}");
+		$urpm->{params}->compute_depslist();
+	    }
+
+	    #- there has been a problem with provides not resolved on files, there
+	    #- must be at least 2 linked pass on the whole process.
+	    if ($urpm->{params}->get_unresolved_provides_files() > 0) {
+		#- cleaning.
+		$urpm->{params}->clean();
+
+		foreach my $medium (@{$urpm->{media}}) {
+		    $medium->{ignore} and next;
+		    $urpm->{params}->read_hdlists("$urpm->{statedir}/$medium->{hdlist}");
+		}
+		$urpm->{params}->keep_only_cleaned_provides_files();
+		foreach my $medium (@{$urpm->{media}}) {
+		    $medium->{ignore} and next;
+		    $urpm->{params}->read_hdlists("$urpm->{statedir}/$medium->{hdlist}");
+		    $urpm->{params}->compute_depslist();
+		}
+	    }
+
+	    #- once everything has been computed, write back the files to
+	    #- sync the urpmi database.
+	    $urpm->write_base_files();
+	    $urpm->{modified} = 0;
+	}
+	#- this file is written in any cases.
+	$urpm->write_config();
+
+	#- now everything is finished.
+	system("sync");
+    }
+}
+
+#- check for necessity of mounting some directory to get access
+sub try_mounting {
+    my ($urpm, $dir) = @_;
+
+    if (!-e $dir) {
+	my ($fdir, $pdir, $v, %fstab) = $dir;
+
+	#- read /etc/fstab and check for existing mount point.
+	local (*F, $_);
+	open F, "/etc/fstab";
+	while (<F>) {
+	    /^\s*\S+\s+(\/\S+)/ and $fstab{$1} = 0;
+	}
+	open F, "/etc/mtab";
+	while (<F>) {
+	    /^\s*\S+\s+(\/\S+)/ and $fstab{$1} = 1;
+	}
+	close F;
+
+	#- try to follow symlink, too complex symlink graph may not
+	#- be seen.
+	while ($v = readlink $fdir) {
+	    if ($fdir =~ /^\//) {
+		$fdir = $v;
+	    } else {
+		while ($v =~ /^\.\.\/(.*)/) {
+		    $v = $1;
+		    $fdir =~ s/^(.*)\/[^\/]+\/*/$1/;
+		}
+		$fdir .= "/$v";
+	    }
+	}
+
+	#- check the presence of parent directory to mount directory.
+	foreach (split '/', $fdir) {
+	    length($_) or next;
+	    $pdir .= "/$_";
+	    foreach ($pdir, "$pdir/") {
+		exists $fstab{$_} && !$fstab{$_} and $fstab{$pdir} = 1, `mount $pdir 2>/dev/null`;
+	    }
+	}
+    }
+}
+
+#- read depslist file using rpmtools, this file is not managed directly by urpm.
+sub read_depslist {
+    my ($urpm) = @_;
+
+    local *F;
+    open F, $urpm->{depslist} or $urpm->{error}("unable to read depslist file [$urpm->{depslist}]"), return;
+    $urpm->{params}->read_depslist(\*F);
+    close F;
+    $urpm->{log}("read depslist file [$urpm->{depslist}]");
+    1;
+}
+
+#- read providest file using rpmtools, this file is not managed directly by urpm.
+sub read_provides {
+    my ($urpm) = @_;
+
+    local *F;
+    open F, $urpm->{provides} or $urpm->{error}("unable to read provides file [$urpm->{provides}]"), return;
+    $urpm->{params}->read_provides(\*F);
+    close F;
+    $urpm->{log}("read provides file [$urpm->{provides}]");
+    1;
+}
+
+#- read providest file using rpmtools, this file is not managed directly by urpm.
+sub read_compss {
+    my ($urpm) = @_;
+
+    local *F;
+    open F, $urpm->{compss} or $urpm->{error}("unable to read compss file [$urpm->{compss}]"), return;
+    $urpm->{params}->read_compss(\*F);
+    close F;
+    $urpm->{log}("read compss file [$urpm->{compss}]");
+    1;
+}
+
+#- write base files using rpmtools, these files are not managed directly by urpm.
+sub write_base_files {
+    my ($urpm) = @_;
+    local *F;
+
+    open F, ">$urpm->{depslist}" or $urpm->{error}("unable to write depslist file [$urpm->{depslist}]");
+    $urpm->{params}->write_depslist(\*F);
+    close F;
+    $urpm->{log}("write depslist file [$urpm->{depslist}]");
+
+    open F, ">$urpm->{provides}" or $urpm->{error}("unable to write provides file [$urpm->{provides}]");
+    $urpm->{params}->write_provides(\*F);
+    close F;
+    $urpm->{log}("write provides file [$urpm->{provides}]");
+
+    open F, ">$urpm->{compss}" or $urpm->{error}("unable to write compss file [$urpm->{compss}]");
+    $urpm->{params}->write_compss(\*F);
+    close F;
+    $urpm->{log}("write compss file [$urpm->{compss}]");
+}
+
+#- search packages registered by their name by storing their id into packages hash.
+sub search_packages {
+    my ($urpm, $packages, $names, %options) = @_;
+    my (%exact, %found, %foundi);
+
+    foreach my $v (@$names) {
+	#- it is a way of speedup, providing the name of a package directly help
+	#- to find the package.
+	#- this is necessary if providing a name list of package to upgrade.
+	if ($urpm->{params}{info}{$v}) {
+	    $exact{$v} = $urpm->{params}{info}{$v}; next;
+	}
+
+	my $qv = quotemeta $v;
+	foreach (keys %{$urpm->{params}{info}}) {
+	    my $info = $urpm->{params}{info}{$_};
+	    my $pack = $info->{name} .'-'. $info->{version} .'-'. $info->{release};
+
+	    $pack =~ /^$qv-[^-]+-[^-]+$/ and $exact{$v} = $info;
+	    $pack =~ /^$qv-[^-]+$/ and $exact{$v} = $info;
+	    $pack =~ /$qv/ and push @{$found{$v}}, $info;
+	    $pack =~ /$qv/i and push @{$foundi{$v}}, $info; 
+	}
+    }
+
+    my $result = 1;
+    foreach (@$names) {
+	my $info = $exact{$_};
+	if ($info) {
+	    $packages->{$info->{id}} = undef;
+	} else {
+	    my $l = $found{$_} || $foundi{$_};
+	    if (@{$l || []} == 0) {
+		$urpm->{error}(_("no package named %s\n", $_)); $result = 0;
+	    } elsif (@$l > 1 && !$options{all}) {
+		$urpm->{error}(_("The following packages contain %s: %s\n", $_, join(' ', map { $_->{name} } @$l))); $result = 0; 
+	    } else {
+		foreach (@$l) {
+		    $packages->{$_->{id}} = undef;
+		}
+	    }
+	}
+    }
+
+    #- return true if no error have been encoutered, else false.
+    $result;
+}
+
+#- compute the closure of a list, mostly internal function for filter_packages_to_upgrade.
+#- limited to values in packages which should not be a reference.
+#- package are identified by their id.
+sub compute_closure {
+    my ($urpm, $packages, $installed, $select_choices) = @_;
+
+    #- select first level of packages, as in packages list will only be
+    #- examined deps of each.
+    @{$packages}{keys %$packages} = ();
+
+    #- at this level, compute global closure of what is requested, regardless of
+    #- choices for which all package in the choices are taken and their dependancies.
+    #- allow iteration over a modifying list.
+    my $id;
+    my @packages = keys %$packages;
+    while (defined($id = shift @packages)) {
+	#- get a relocated id if possible, by this way.
+	$id = $urpm->{params}{depslist}[$id]{id};
+
+	#- avoid a package if it has already been dropped in the sense of
+	#- selected directly by another way.
+	foreach ($id, split ' ', $urpm->{params}{depslist}[$id]{deps}) {
+	    if (/\|/) {
+		my ($follow_id, @upgradable_choices);
+		my @choices = map { $urpm->{params}{depslist}[$_]{id} } split /\|/, $_;
+		foreach (@choices) {
+		    $installed && $installed->{$_} and $follow_id = -1, last;
+		    exists $packages->{$_} && ! ref $packages->{$_} and $follow_id = $_, last;
+		    $installed && exists $installed->{$_} and push @upgradable_choices, $_;
+		}
+		unless ($follow_id) {
+		    #- if there are at least one upgradable choice, use it instead
+		    #- of asking the user to chose among a list.
+		    if (@upgradable_choices == 1) {
+			push @packages, $upgradable_choices[0];
+		    } else {
+			@upgradable_choices > 1 and @choices = @upgradable_choices;
+			$select_choices and push @packages, $select_choices->($urpm, @choices);
+			foreach (@choices) {
+			    push @{$packages->{$_} ||= []}, \@choices;
+			}
+		    }
+		}
+	    } else {
+		if (ref $packages->{$_}) {
+		    #- all the choices associated here have to be dropped, need to copy else
+		    #- there could be problem with foreach on a modifying list.
+		    foreach my $choices (@{$packages->{$id}}) {
+			foreach (@$choices) {
+			    $packages->{$_} = [ grep { $_ != $choices } @{$packages->{$_}} ];
+			    @{$packages->{$_}} > 0 or delete $packages->{$_};
+			}
+		    }
+		}
+		if ($installed && $installed->{$_}) {
+		    delete $packages->{$_};
+		} else {
+		    $packages->{$_} = $installed && ! exists $installed->{$_};
+		}
+	    }
+	}
+    }
+}
+
+#- filter the packages list (assuming only the key is registered, so undefined
+#- value stored) to keep only packages that need to be upgraded,
+#- additionnal packages will be stored using non null values,
+#- choice will have a list of other choices as values,
+#- initial packages will have a 0 stored as values.
+#- options allow changing some behaviour of the algorithms:
+#-   complete -> perform a complete closure before trying to look for upgrade.
+sub filter_packages_to_upgrade {
+    my ($urpm, $packages, $select_choices, %options) = @_;
+    my ($id, %closures, %installed, @packages_installed);
+
+    #- request the primary list to rpmlib if complete mode is not activated.
+    if (!$options{complete} &&
+	rpmtools::get_packages_installed('', \@packages_installed,
+					 [ map { $urpm->{params}{depslist}[$_]{name} } keys %$packages ])) {
+	#- there are not too many packages selected here to allow
+	#- take care of package up-to-date at this point,
+	#- so check version and if the package does not need to
+	#- updated, ignore it and his dependancies.
+	foreach (@packages_installed) {
+	    my $pkg = $urpm->{params}{info}{$_->{name}}; $pkg or next; #- TODO error
+	    my $cmp = rpmtools::version_compare($pkg->{version}, $_->{version});
+	    $installed{$pkg->{id}} = !($cmp > 0 || $cmp == 0 && rpmtools::version_compare($pkg->{release}, $_->{release}) > 0)
+	      and delete $packages->{$pkg->{id}};
+	}
+    }
+
+    #- select first level of packages, as in packages list will only be
+    #- examined deps of each.
+    #- at this level, compute global closure of what is requested, regardless of
+    #- choices for which all package in the choices are taken and their dependancies.
+    #- allow iteration over a modifying list.
+    @closures{keys %$packages} = ();
+    $urpm->compute_closure(\%closures, undef, sub { my ($urpm, @l) = @_; @l });
+
+    #- closures has been done so that its keys are the package that may be examined.
+    #- according to number of keys, get all package installed or only the necessary
+    #- packages.
+    #- do not take care of already examined packages.
+    delete @closures{keys %installed};
+    if (scalar(keys %closures) < 100) {
+	rpmtools::get_packages_installed('', \@packages_installed,
+					 [ map { $urpm->{params}{depslist}[$_]{name} } keys %closures ]);
+    } else {
+	rpmtools::get_all_packages_installed('', \@packages_installed);
+    }
+
+    #- packages installed that may be upgraded have to be examined now.
+    foreach (@packages_installed) {
+	my $pkg = $urpm->{params}{info}{$_->{name}}; $pkg or next; #- TODO error
+	exists $closures{$pkg->{id}} or next;
+	my $cmp = rpmtools::version_compare($pkg->{version}, $_->{version});
+	$installed{$pkg->{id}} = !($cmp > 0 || $cmp == 0 && rpmtools::version_compare($pkg->{release}, $_->{release}) > 0)
+	  and delete $packages->{$pkg->{id}};
+    }
+
+    #- recompute closure but ask for which package to select on a choices.
+    #- this is necessary to have the result before the end else some dependancy may
+    #- be losed or added.
+    #- accept no choice allow to browse list, and to compute it with more iteration.
+    %closures = (); @closures{keys %$packages} = ();
+    $urpm->compute_closure(\%closures, \%installed, $select_choices);
+
+    #- restore package to match selection done, update the values according to
+    #- need upgrade (0), requested (undef), already installed (not present) or
+    #- newly added (1).
+    #- choices if not chosen are present as ref.
+    my @packages = keys %$packages;
+    %$packages = %closures;
+    @{$packages}{@packages} = ();
+
+    $packages;
+}
+
+
+1;