package urpm; use strict; use vars qw($VERSION @ISA); $VERSION = '3.4'; @ISA = qw(URPM); =head1 NAME urpm - Mandrake perl tools to handle urpmi database =head1 SYNOPSYS require urpm; my $urpm = new urpm; $urpm->read_config(); $urpm->add_medium('medium_ftp', 'ftp://ftp.mirror/pub/linux/distributions/mandrake-devel/cooker/i586/Mandrake/RPMS', 'synthesis.hdlist.cz', update => 0); $urpm->add_distrib_media('stable', 'removable://mnt/cdrom', update => 1); $urpm->select_media('contrib', 'update'); $urpm->update_media(%options); $urpm->write_config(); my $urpm = new urpm; $urpm->read_config(nocheck_access => $uid > 0); foreach (grep { !$_->{ignore} } @{$urpm->{media} || []}) { $urpm->parse_synthesis($_); } if (@files) { push @names, $urpm->register_rpms(@files); } $urpm->relocate_depslist_provides(); my %packages; @names and $urpm->search_packages(\%packages, [ @names], use_provides => 1); if ($auto_select) { my (%to_remove, %keep_files); $urpm->select_packages_to_upgrade('', \%packages, \%to_remove, \%keep_files, use_parsehdlist => $complete); } $urpm->filter_packages_to_upgrade(\%packages, $ask_choice); $urpm->deselect_unwanted_packages(\%packages); my ($local_sources, $list, $local_to_removes) = $urpm->get_source_packages(\%packages); my %sources = $urpm->download_source_packages($local_sources, $list, 'force_local', $ask_medium_change); my @rpms_install = grep { $_ !~ /\.src.\.rpm/ } values %{ $urpm->extract_packages_to_install(\%sources) || {}}; my @rpms_upgrade = grep { $_ !~ /\.src.\.rpm/ } values %sources; =head1 DESCRIPTION C is used by urpmi executables to manipulate packages and media on a Linux-Mandrake distribution. =head1 SEE ALSO perl-URPM (obsolete rpmtools) package is used to manipulate at a lower level hdlist and rpm files. =head1 COPYRIGHT Copyright (C) 2000,2001,2002 MandrakeSoft 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 URPM; use POSIX; use Locale::GetText; #- I18N. setlocale (LC_ALL, ""); Locale::GetText::textdomain ("urpmi"); sub _ { my ($format, @params) = @_; sprintf(Locale::GetText::I_($format), @params); } #- create a new urpm object. sub new { my ($class) = @_; bless { config => "/etc/urpmi/urpmi.cfg", skiplist => "/etc/urpmi/skip.list", instlist => "/etc/urpmi/inst.list", statedir => "/var/lib/urpmi", cachedir => "/var/cache/urpmi", media => undef, provides => {}, depslist => [], sync => \&sync_webfetch, #- first argument is directory, others are url to fetch. fatal => sub { printf STDERR "%s\n", $_[1]; exit($_[0]) }, 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; $_ } #- syncing algorithms, currently is implemented wget and curl methods, #- webfetch is trying to find the best (and one which will work :-) sub sync_webfetch { -x "/usr/bin/curl" and return &sync_curl; -x "/usr/bin/wget" and return &sync_wget; die _("no webfetch (curl or wget currently) found\n"); } sub sync_wget { -x "/usr/bin/wget" or die _("wget is missing\n"); my $options = shift @_; system "/usr/bin/wget", (ref $options && $options->{quiet} ? ("-q") : ()), "-NP", (ref $options ? $options->{dir} : $options), @_; $? == 0 or die _("wget failed: exited with %d or signal %d\n", $? >> 8, $? & 127); } sub sync_curl { -x "/usr/bin/curl" or die _("curl is missing\n"); my $options = shift @_; chdir (ref $options ? $options->{dir} : $options); my (@ftp_files, @other_files); foreach (@_) { /^ftp:\/\/.*\/([^\/]*)$/ && -s $1 > 8192 and do { push @ftp_files, $_; next }; #- manage time stamp for large file only. push @other_files, $_; } if (@ftp_files) { my ($cur_ftp_file, %ftp_files_info); require Date::Manip; #- prepare to get back size and time stamp of each file. local *CURL; open CURL, "/usr/bin/curl -I " . join(" ", map { "'$_'" } @ftp_files) . " |"; while () { if (/Content-Length:\s*(\d+)/) { !$cur_ftp_file || exists $ftp_files_info{$cur_ftp_file}{size} and $cur_ftp_file = shift @ftp_files; $ftp_files_info{$cur_ftp_file}{size} = $1; } if (/Last-Modified:\s*(.*)/) { !$cur_ftp_file || exists $ftp_files_info{$cur_ftp_file}{time} and $cur_ftp_file = shift @ftp_files; $ftp_files_info{$cur_ftp_file}{time} = Date::Manip::ParseDate($1); $ftp_files_info{$cur_ftp_file}{time} =~ s/(\d{6}).{4}(.*)/$1$2/; #- remove day and hour. } } close CURL; #- now analyse size and time stamp according to what already exists here. if (@ftp_files) { #- re-insert back shifted element of ftp_files, because curl output above #- have not been parsed correctly, in doubt download them all. push @ftp_files, keys %ftp_files_info; } else { #- for that, it should be clear ftp_files is empty... else a above work is #- use less. foreach (keys %ftp_files_info) { my ($lfile) = /\/([^\/]*)$/ or next; #- strange if we can't parse it correctly. my $ltime = Date::Manip::ParseDate(scalar gmtime((stat $1)[9])); $ltime =~ s/(\d{6}).{4}(.*)/$1$2/; #- remove day and hour. -s $lfile == $ftp_files_info{$_}{size} && $ftp_files_info{$_}{time} eq $ltime or push @ftp_files, $_; } } } #- http files (and other files) are correctly managed by curl to conditionnal download. #- options for ftp files, -R (-O )* #- options for http files, -R (-z file -O )* if (my @all_files = ((map { ("-O", $_ ) } @ftp_files), (map { /\/([^\/]*)$/ ? ("-z", $1, "-O", $_) : () } @other_files))) { system "/usr/bin/curl", (ref $options && $options->{quiet} ? ("-s") : ()), "-R", "-f", @all_files; $? == 0 or die _("curl failed: exited with %d or signal %d\n", $? >> 8, $? & 127); } } #- read /etc/urpmi/urpmi.cfg as config file, keep compability with older #- configuration file by examining if one entry is of the form #- { #- ... #- } #- else only this form is used #- #- with sub read_config { my ($urpm, %options) = @_; #- keep in mind if it has been called before. $urpm->{media} and return; $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 () { chomp; s/#.*$//; s/^\s*//; s/\s*$//; /^(.*?[^\\])\s+(?:(.*?[^\\])\s+)?{$/ and do { #- urpmi.cfg format extention my $medium = { name => unquotespace($1), clear_url => unquotespace($2) }; while () { chomp; s/#.*$//; s/^\s*//; s/\s*$//; /^hdlist\s*:\s*(.*)$/ and $medium->{hdlist} = $1, next; /^with_hdlist\s*:\s*(.*)$/ and $medium->{with_hdlist} = $1, next; /^list\s*:\s*(.*)$/ and $medium->{list} = $1, next; /^removable\s*:\s*(.*)$/ and $medium->{removable} = $1, next; /^update\s*$/ and $medium->{update} = 1, next; /^ignore\s*$/ and $medium->{ignore} = 1, next; /^synthesis\s*$/ and $medium->{synthesis} = 1, next; /^modified\s*$/ and $medium->{modified} = 1, next; $_ eq '}' and last; $_ and $urpm->{error}(_("syntax error in config file at line %s", $.)); } $urpm->probe_medium($medium, %options) and push @{$urpm->{media}}, $medium; next; }; /^(.*?[^\\])\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, %options) and push @{$urpm->{media}}, $medium; next; }; /^(.*?[^\\])\s+(?:(.*?[^\\])\s*)?$/ and do { #- urpmi.cfg old format (assume hdlist..cz2?) my $medium = { name => unquotespace($1), clear_url => unquotespace($2) }; $urpm->probe_medium($medium, %options) and push @{$urpm->{media}}, $medium; next; }; $_ and $urpm->{error}(_("syntax error in config file at line %s", $.)); } 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 \"%s\" tries to use an already used hdlist, medium ignored", $_->{name})); $hdlists{$_->{hdlist}} = undef; exists $lists{$_->{list}} and $_->{ignore} = 1, $urpm->{error}(_("medium \"%s\" tries to use an already used list, medium ignored", $_->{name})); $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 care of medium \"%s\" as list file is already used by another medium", $2)); } else { my $medium; foreach (@{$urpm->{media}}) { $_->{name} eq $2 and $medium = $_, last; } $medium and $urpm->{error}(_("unable to use name \"%s\" for unnamed medium because it is already used", $2)), next; $medium = { name => $2, hdlist => "hdlist.$1", list => "list.$2" }; $urpm->probe_medium($medium, %options) and push @{$urpm->{media}}, $medium; } } else { $urpm->{error}(_("unable to take medium \"%s\" into account as no list file [%s] exists", $2, "$urpm->{statedir}/list.$2")); } } else { $urpm->{error}(_("unable to determine medium of this hdlist file [%s]", $_)); } } #- check the presence of hdlist file and list file if necessary. unless ($options{nocheck_access}) { foreach (@{$urpm->{media}}) { $_->{ignore} and next; -r "$urpm->{statedir}/$_->{hdlist}" || -r "$urpm->{statedir}/synthesis.$_->{hdlist}" && $_->{synthesis} or $_->{ignore} = 1, $urpm->{error}(_("unable to access hdlist file of \"%s\", medium ignored", $_->{name})); $_->{list} && -r "$urpm->{statedir}/$_->{list}" or $_->{ignore} = 1, $urpm->{error}(_("unable to access list file of \"%s\", medium ignored", $_->{name})); } } } #- probe medium to be used, take old medium into account too. sub probe_medium { my ($urpm, $medium, %options) = @_; local $_; my $existing_medium; foreach (@{$urpm->{media}}) { $_->{name} eq $medium->{name} and $existing_medium = $_, last; } $existing_medium and $urpm->{error}(_("trying to bypass existing medium \"%s\", avoiding", $medium->{name})), return; 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 \"%s\", medium ignored", $medium->{name})); } unless ($medium->{ignore} || $medium->{list}) { $medium->{list} = "list.$medium->{name}"; -e "$urpm->{statedir}/$medium->{list}" or $medium->{ignore} = 1, $urpm->{error}(_("unable to find list file for \"%s\", medium ignored", $medium->{name})); } #- there is a little more to do at this point as url is not known, inspect directly list file for it. unless ($medium->{url} || $medium->{clear_url}) { my %probe; local *L; open L, "$urpm->{statedir}/$medium->{list}"; while () { #- /./ is end of url marker in list file (typically generated by a #- find . -name "*.rpm" > list #- for exportable list file. /^(.*)\/\.\// and $probe{$1} = undef; /^(.*)\/[^\/]*$/ and $probe{$1} = undef; } close L; foreach (sort { length($a) <=> length($b) } keys %probe) { if ($medium->{url}) { $medium->{url} eq substr($_, 0, length($medium->{url})) or $medium->{ignore} || $urpm->{error}(_("incoherent list file for \"%s\", medium ignored", $medium->{name})), $medium->{ignore} = 1, last; } else { $medium->{url} = $_; } } unless ($options{nocheck_access}) { $medium->{url} or $medium->{ignore} || $urpm->{error}(_("unable to inspect list file for \"%s\", medium ignored", $medium->{name})), $medium->{ignore} = 1; #, last; keeping it cause perl to exit caller loop ... } } $medium->{url} ||= $medium->{clear_url}; #- probe removable device. $urpm->probe_removable_device($medium); #- clear URLs for trailing /es. $medium->{url} =~ s|(.*?)/*$|$1|; $medium->{clear_url} =~ s|(.*?)/*$|$1|; $medium; } #- probe device associated with a removable device. sub probe_removable_device { my ($urpm, $medium) = @_; if ($medium->{url} =~ /^removable_?([^_:]*)(?:_[^:]*)?:/) { $medium->{removable} ||= $1 && "/dev/$1"; } else { delete $medium->{removable}; } #- try to find device to open/close for removable medium. if (exists $medium->{removable}) { if (my ($dir) = $medium->{url} =~ /(?:file|removable)[^:]*:\/(.*)/) { my @mntpoints2devices = $urpm->find_mntpoints($dir, 'device'); if (@mntpoints2devices > 2) { #- return value is suitable for an hash. $urpm->{log}(_("too many mount points for removable medium \"%s\"", $medium->{name})); $urpm->{log}(_("taking removable device as \"%s\"", $mntpoints2devices[-1])); #- take the last one. } if (@mntpoints2devices) { if ($medium->{removable} && $medium->{removable} ne $mntpoints2devices[-1]) { $urpm->{log}(_("using different removable device [%s] for \"%s\"", $mntpoints2devices[-1], $medium->{name})); } $medium->{removable} = $mntpoints2devices[-1]; } else { $urpm->{error}(_("unable to retrieve pathname for removable medium \"%s\"", $medium->{name})); } } else { $urpm->{error}(_("unable to retrieve pathname for removable medium \"%s\"", $medium->{name})); } } } #- 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->{fatal}(6, _("unable to write config file [%s]", $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(update ignore synthesis modified)) { $medium->{$_} and printf F " %s\n", $_; } printf F "}\n\n"; } close F; $urpm->{log}(_("write config file [%s]", $urpm->{config})); #- everything should be synced now. delete $urpm->{modified}; } #- read urpmi.cfg file as well as synthesis file needed. sub configure { my ($urpm, %options) = @_; $urpm->clean; $urpm->read_config(%options); if ($options{media}) { $urpm->select_media(split ',', $options{media}); foreach (grep { !$_->{modified} } @{$urpm->{media} || []}) { #- this is only a local ignore that will not be saved. $_->{ignore} = 1; } } foreach (grep { !$_->{ignore} && (!$options{update} || $_->{update}) } @{$urpm->{media} || []}) { $urpm->{log}(_("examining synthesis file [%s]", "$urpm->{statedir}/synthesis.$_->{hdlist}")); ($_->{start}, $_->{end}) = $urpm->parse_synthesis("$urpm->{statedir}/synthesis.$_->{hdlist}"); } } #- add a new medium, sync the config file accordingly. sub add_medium { my ($urpm, $name, $url, $with_hdlist, %options) = @_; #- 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}}) { $_->{name} eq $name and $medium = $_; } $medium and $urpm->{fatal}(5, _("medium \"%s\" already exists", $medium->{name})); #- clear URLs for trailing /es. $url =~ s|(.*?)/*$|$1|; #- creating the medium info. $medium = { name => $name, url => $url, hdlist => "hdlist.$name.cz", list => "list.$name", update => $options{update}, modified => 1, }; #- check to see if the medium is using file protocol or removable medium. if (my ($prefix, $dir) = $url =~ /^(removable[^:]*|file):\/(.*)/) { #- add some more flags for this type of medium. $medium->{clear_url} = $url; #- try to find device associated. $urpm->probe_removable_device($medium); } #- 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. #- this will be done automatically by transfering modified flag from medium to global. $urpm->{log}(_("added medium %s", $name)); } #- add distribution media, according to url given. sub add_distrib_media { my ($urpm, $name, $url, %options) = @_; my ($hdlists_file); #- make sure configuration has been read. $urpm->{media} or $urpm->read_config(); #- try to copy/retrive Mandrake/basehdlists file. if (my ($dir) = $url =~ /^(?:removable[^:]*|file):\/(.*)/) { $hdlists_file = reduce_pathname("$dir/Mandrake/base/hdlists"); $urpm->try_mounting($hdlists_file) or $urpm->{error}(_("unable to access first installation medium")), return; if (-e $hdlists_file) { unlink "$urpm->{cachedir}/partial/hdlists"; $urpm->{log}(_("copying hdlists file...")); system("cp", "-a", $hdlists_file, "$urpm->{cachedir}/partial/hdlists") ? $urpm->{log}(_("...copying failed")) : $urpm->{log}(_("...copying done")); } else { $urpm->{error}(_("unable to access first installation medium (no Mandrake/base/hdlists file found)")), return; } } else { #- try to get the description if it has been found. unlink "$urpm->{cachedir}/partial/hdlists"; eval { $urpm->{log}(_("retrieving hdlists file...")); $urpm->{sync}("$urpm->{cachedir}/partial", reduce_pathname("$url/Mandrake/base/hdlists")); $urpm->{log}(_("...retrieving done")); }; $@ and $urpm->{log}(_("...retrieving failed: %s", $@)); if (-e "$urpm->{cachedir}/partial/hdlists") { $hdlists_file = "$urpm->{cachedir}/partial/hdlists"; } else { $urpm->{error}(_("unable to access first installation medium (no Mandrake/base/hdlists file found)")), return; } } #- cosmetic update of name if it contains blank char. $name =~ /\s/ and $name .= ' '; #- at this point, we have found an hdlists file, so parse it #- and create all necessary medium according to it. local *HDLISTS; if (open HDLISTS, $hdlists_file) { my $medium = 1; foreach () { chomp; s/\s*#.*$//; /^\s*$/ and next; m/^\s*(hdlist\S*\.cz2?)\s+(\S+)\s*(.*)$/ or $urpm->{error}(_("invalid hdlist description \"%s\" in hdlists file"), $_); my ($hdlist, $rpmsdir, $descr) = ($1, $2, $3); $urpm->add_medium($name ? "$descr ($name$medium)" : $descr, "$url/$rpmsdir", "../base/$hdlist", %options); ++$medium; } close HDLISTS; } else { $urpm->{error}(_("unable to access first installation medium (no Mandrake/base/hdlists file found)")), return; } } 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. #- in such case, try to find the unique medium (or list candidate #- media found). foreach (keys %media) { unless ($media{$_}) { my $q = quotemeta; my (@found, @foundi); foreach my $medium (@{$urpm->{media}}) { $medium->{name} =~ /$q/ and push @found, $medium; $medium->{name} =~ /$q/i and push @foundi, $medium; } if (@found == 1) { $found[0]{modified} = 1; } elsif (@foundi == 1) { $foundi[0]{modified} = 1; } elsif (@found == 0 && @foundi == 0) { $urpm->{error}(_("trying to select inexistent medium \"%s\"", $_)); } else { #- multiple element in found or foundi list. $urpm->{error}(_("trying to select multiple medium: %s", join(", ", map { _("\"%s\"", $_->{name}) } (@found ? @found : @foundi)))); } } } } sub remove_selected_media { my ($urpm) = @_; my @result; foreach (@{$urpm->{media}}) { if ($_->{modified}) { $urpm->{log}(_("removing medium \"%s\"", $_->{name})); #- mark to re-write configuration. $urpm->{modified} = 1; #- remove file associated with this medium. foreach ($_->{hdlist}, $_->{list}, "synthesis.$_->{hdlist}", "descriptions.$_->{name}", "$_->{name}.cache") { unlink "$urpm->{statedir}/$_"; } } else { push @result, $_; #- not removed so keep it } } #- restore newer media list. $urpm->{media} = \@result; } #- update urpmi database regarding the current configuration. #- take care of modification and try some trick to bypass #- computational of base files. #- allow options : #- all -> all medium are rebuilded. #- force -> try to force rebuilding base files (1) or hdlist from rpms files (2). #- probe_with_hdlist -> probe synthesis or hdlist. #- ratio -> use compression ratio (with gzip, default is 4) #- noclean -> keep header directory cleaned. sub update_media { my ($urpm, %options) = @_; #- do not trust existing hdlist and try to recompute them. my ($cleaned_cache); #- take care of some options. $cleaned_cache = !$options{noclean}; #- avoid trashing existing configuration in this case. $urpm->{media} or return; #- now we need additional methods not defined by default in URPM. require URPM::Build; #- avoid putting a require on Fcntl ':flock' (which is perl and not perl-base). my ($LOCK_EX, $LOCK_NB, $LOCK_UN) = (2, 4, 8); #- lock urpmi database. local (*LOCK_FILE); open LOCK_FILE, $urpm->{statedir}; flock LOCK_FILE, $LOCK_EX|$LOCK_NB or $urpm->{fatal}(7, _("urpmi database locked")); #- 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. $urpm->clean; foreach my $medium (@{$urpm->{media}}) { #- take care of modified medium only or all if all have to be recomputed. $medium->{ignore} and next; #- and create synthesis file associated if it does not already exists... -s "$urpm->{statedir}/synthesis.$medium->{hdlist}" > 32 or $medium->{modified_synthesis} = 1; #- but do not take care of removable media for all. $medium->{modified} ||= $options{all} && $medium->{url} !~ /removable/; unless ($medium->{modified}) { #- the medium is not modified, but for computing dependencies, #- we still need to read it and all synthesis will be written if #- a unresolved provides is found. #- to speed up the process, we only read the synthesis at the begining. $urpm->{log}(_("examining synthesis file [%s]", "$urpm->{statedir}/synthesis.$medium->{hdlist}")); ($medium->{start}, $medium->{end}) = $urpm->parse_synthesis("$urpm->{statedir}/synthesis.$medium->{hdlist}"); unless (defined $medium->{start} && defined $medium->{end}) { #- this is almost a fatal error, ignore it by default? $urpm->{error}(_("problem reading synthesis file of medium \"%s\"", $medium->{name})); $medium->{ignore} = 1; } 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):\/(.*)/) { #- try to figure a possible hdlist_path (or parent directory of searched directory. #- this is used to probe possible hdlist file. my $with_hdlist_dir = reduce_pathname($dir . ($medium->{with_hdlist} ? "/$medium->{with_hdlist}" : "/..")); #- the directory given does not exist and may be accessible #- by mounting some other. try to figure out these directory and #- mount everything necessary. if ($options{force} < 2 && ($options{probe_with_hdlist} || $medium->{with_hdlist})) { $urpm->try_mounting($with_hdlist_dir) or $urpm->{log}(_("unable to access medium \"%s\"", $medium->{name})), next; } else { $urpm->try_mounting($dir) or $urpm->{log}(_("unable to access medium \"%s\"", $medium->{name})), next; } #- try to probe for possible with_hdlist parameter, unless #- it is already defined (and valid). if ($options{probe_with_hdlist} && (!$medium->{with_hdlist} || ! -e "$dir/$medium->{with_hdlist}")) { my ($suffix) = $dir =~ /RPMS([^\/]*)\/*$/; if (-s "$dir/synthesis.hdlist.cz" > 32) { $medium->{with_hdlist} = "./synthesis.hdlist.cz"; } elsif (-s "$dir/synthesis.hdlist$suffix.cz" > 32) { $medium->{with_hdlist} = "./synthesis.hdlist$suffix.cz"; } elsif (defined $suffix && !$suffix && -s "$dir/synthesis.hdlist1.cz" > 32) { $medium->{with_hdlist} = "./synthesis.hdlist1.cz"; } elsif (defined $suffix && !$suffix && -s "$dir/synthesis.hdlist2.cz" > 32) { $medium->{with_hdlist} = "./synthesis.hdlist2.cz"; } elsif (-s "$dir/../synthesis.hdlist$suffix.cz" > 32) { $medium->{with_hdlist} = "../synthesis.hdlist$suffix.cz"; } elsif (defined $suffix && !$suffix && -s "$dir/../synthesis.hdlist1.cz" > 32) { $medium->{with_hdlist} = "../synthesis.hdlist1.cz"; } elsif (-s "$dir/../base/hdlist$suffix.cz" > 32) { $medium->{with_hdlist} = "../base/hdlist$suffix.cz"; } elsif (defined $suffix && !$suffix && -s "$dir/../base/hdlist1.cz" > 32) { $medium->{with_hdlist} = "../base/hdlist1.cz"; } #- redo... $with_hdlist_dir = reduce_pathname($dir . ($medium->{with_hdlist} ? "/$medium->{with_hdlist}" : "/..")); } #- try to get the description if it has been found. unlink "$urpm->{statedir}/descriptions.$medium->{name}"; if (-e "$dir/../descriptions") { $urpm->{log}(_("copying description file of \"%s\"...", $medium->{name})); system("cp", "-a", "$dir/../descriptions", "$urpm->{statedir}/descriptions.$medium->{name}") ? $urpm->{log}(_("...copying failed")) : $urpm->{log}(_("...copying done")); } #- if the source hdlist is present and we are not forcing using rpms file if ($options{force} < 2 && $medium->{with_hdlist} && -e $with_hdlist_dir) { unlink "$urpm->{cachedir}/partial/$medium->{hdlist}"; $urpm->{log}(_("copying source hdlist (or synthesis) of \"%s\"...", $medium->{name})); system("cp", "-a", "$with_hdlist_dir", "$urpm->{cachedir}/partial/$medium->{hdlist}") ? $urpm->{log}(_("...copying failed")) : $urpm->{log}(_("...copying done")); -s "$urpm->{cachedir}/partial/$medium->{hdlist}" > 32 or $error = 1, $urpm->{error}(_("copy of [%s] failed", "$with_hdlist_dir")); #- check if the file are equals... and no force copy... unless ($error || $options{force}) { my @sstat = stat "$urpm->{cachedir}/partial/$medium->{hdlist}"; my @lstat = stat "$urpm->{statedir}/$medium->{hdlist}"; if ($sstat[7] == $lstat[7] && $sstat[9] == $lstat[9]) { #- the two files are considered equal here, the medium is so not modified. $medium->{modified} = 0; unlink "$urpm->{cachedir}/partial/$medium->{hdlist}"; #- as previously done, just read synthesis file here, this is enough. $urpm->{log}(_("examining synthesis file [%s]", "$urpm->{statedir}/synthesis.$medium->{hdlist}")); ($medium->{start}, $medium->{end}) = $urpm->parse_synthesis("$urpm->{statedir}/synthesis.$medium->{hdlist}"); unless (defined $medium->{start} && defined $medium->{end}) { $urpm->{error}(_("problem reading synthesis file of medium \"%s\"", $medium->{name})); $medium->{ignore} = 1; } next; } } #- examine if a local list file is available (always probed according to with_hdlist #- and check hdlist has not be named very strangely... if ($medium->{hdlist} ne 'list') { unlink "$urpm->{cachedir}/partial/list"; my $local_list = $medium->{with_hdlist} =~ /hd(list.*)\.cz$/ ? $1 : 'list'; if (-s "$dir/$local_list") { $urpm->{log}(_("copying source list of \"%s\"...", $medium->{name})); system("cp", "-a", "$dir/$local_list", "$urpm->{cachedir}/partial/list") ? $urpm->{log}(_("...copying failed")) : $urpm->{log}(_("...copying done")); } } } 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. #- make sure rpm filename format is correct and is not a source rpm #- which are not well managed by urpmi. @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. eval { $urpm->{log}(_("reading rpms files from [%s]", $dir)); my @unresolved_before = grep { ! defined $urpm->{provides}{$_} } keys %{$urpm->{provides} || {}}; $medium->{start} = @{$urpm->{depslist}}; $medium->{headers} = [ $urpm->parse_rpms_build_headers(dir => "$urpm->{cachedir}/headers", rpms => \@files, clean => $cleaned_cache, ) ]; $medium->{end} = $#{$urpm->{depslist}}; if ($medium->{start} > $medium->{end}) { #- an error occured (provided there are files in input. delete $medium->{start}; delete $medium->{end}; die "no rpms read\n"; } else { $cleaned_cache = 0; #- make sure the headers will not be removed for another media. my @unresolved_after = grep { ! defined $urpm->{provides}{$_} } keys %{$urpm->{provides} || {}}; @unresolved_before == @unresolved_after or $urpm->{second_pass} = 1; } }; $@ and $error = 1, $urpm->{error}(_("unable to read rpms files from [%s]: %s", $dir, $@)); $error and delete $medium->{headers}; #- do not propagate these. $error or delete $medium->{synthesis}; #- when building hdlist by ourself, drop synthesis property. } else { $error = 1; $urpm->{error}(_("no rpm files found from [%s]", $dir)); } } } else { my $basename; #- try to get the description if it has been found. unlink "$urpm->{cachedir}/partial/descriptions"; if (-e "$urpm->{statedir}/descriptions.$medium->{name}") { rename("$urpm->{statedir}/descriptions.$medium->{name}", "$urpm->{cachedir}/partial/descriptions") or system("mv", "$urpm->{statedir}/descriptions.$medium->{name}", "$urpm->{cachedir}/partial/descriptions"); } eval { $urpm->{log}(_("retrieving description file of \"%s\"...", $medium->{name})); $urpm->{sync}({ dir => "$urpm->{cachedir}/partial", quiet => 1 }, reduce_pathname("$medium->{url}/../descriptions")); $urpm->{log}(_("...retrieving done")); }; if (-e "$urpm->{cachedir}/partial/descriptions") { rename("$urpm->{cachedir}/partial/descriptions", "$urpm->{statedir}/descriptions.$medium->{name}") or system("mv", "$urpm->{cachedir}/partial/descriptions", "$urpm->{statedir}/descriptions.$medium->{name}"); } #- try to probe for possible with_hdlist parameter, unless #- it is already defined (and valid). $urpm->{log}(_("retrieving source hdlist (or synthesis) of \"%s\"...", $medium->{name})); if ($options{probe_with_hdlist}) { my ($suffix) = $dir =~ /RPMS([^\/]*)\/*$/; foreach ($medium->{with_hdlist} ? ($medium->{with_hdlist}) : (), "synthesis.hdlist.cz", "synthesis.hdlist$suffix.cz", !$suffix ? ("synthesis.hdlist1.cz", "synthesis.hdlist2.cz") : (), "../synthesis.hdlist$suffix.cz", !$suffix ? ("../synthesis.hdlist1.cz") : (), "../base/hdlist$suffix.cz", !$suffix ? ("../base/hdlist1.cz") : (), ) { $basename = (/^.*\/([^\/]*)$/ && $1) || $_; unlink "$urpm->{cachedir}/partial/$basename"; eval { $urpm->{sync}({ dir => "$urpm->{cachedir}/partial", quiet => 1 }, reduce_pathname("$medium->{url}/$_")); }; if (!$@ && -s "$urpm->{cachedir}/partial/$basename" > 32) { $medium->{with_hdlist} = $_; $urpm->{log}(_("found probed hdlist (or synthesis) as %s", $basename)); last; #- found a suitable with_hdlist in the list above. } } } else { $basename = ($medium->{with_hdlist} =~ /^.*\/([^\/]*)$/ && $1) || $medium->{with_hdlist}; #- try to sync (copy if needed) local copy after restored the previous one. unlink "$urpm->{cachedir}/partial/$basename"; if ($medium->{synthesis}) { $options{force} || ! -e "$urpm->{statedir}/synthesis.$medium->{hdlist}" or system("cp", "-a", "$urpm->{statedir}/synthesis.$medium->{hdlist}", "$urpm->{cachedir}/partial/$basename"); } else { $options{force} || ! -e "$urpm->{statedir}/$medium->{hdlist}" or system("cp", "-a", "$urpm->{statedir}/$medium->{hdlist}", "$urpm->{cachedir}/partial/$basename"); } eval { $urpm->{sync}("$urpm->{cachedir}/partial", reduce_pathname("$medium->{url}/$medium->{with_hdlist}")); }; if ($@) { $urpm->{log}(_("...retrieving failed: %s", $@)); unlink "$urpm->{cachedir}/partial/$basename"; } } if (-s "$urpm->{cachedir}/partial/$basename" > 32) { $urpm->{log}(_("...retrieving done")); unless ($options{force}) { my @sstat = stat "$urpm->{cachedir}/partial/$basename"; my @lstat = stat "$urpm->{statedir}/$medium->{hdlist}"; if ($sstat[7] == $lstat[7] && $sstat[9] == $lstat[9]) { #- the two files are considered equal here, the medium is so not modified. $medium->{modified} = 0; unlink "$urpm->{cachedir}/partial/$basename"; #- as previously done, just read synthesis file here, this is enough. $urpm->{log}(_("examining synthesis file [%s]", "$urpm->{statedir}/synthesis.$medium->{hdlist}")); ($medium->{start}, $medium->{end}) = $urpm->parse_synthesis("$urpm->{statedir}/synthesis.$medium->{hdlist}"); unless (defined $medium->{start} && defined $medium->{end}) { $urpm->{error}(_("problem reading synthesis file of medium \"%s\"", $medium->{name})); $medium->{ignore} = 1; } next; } } #- the file are different, update local copy. rename("$urpm->{cachedir}/partial/$basename", "$urpm->{cachedir}/partial/$medium->{hdlist}"); #- retrieve of hdlist (or synthesis has been successfull, check if a list file is available. #- and check hdlist has not be named very strangely... if ($medium->{hdlist} ne 'list') { unlink "$urpm->{cachedir}/partial/list"; my $local_list = $medium->{with_hdlist} =~ /hd(list.*)\.cz$/ ? $1 : 'list'; eval { $urpm->{sync}({ dir => "$urpm->{cachedir}/partial", quiet => 1}, reduce_pathname("$medium->{url}/$local_list")); $local_list ne 'list' and rename("$urpm->{cachedir}/partial/$local_list", "$urpm->{cachedir}/partial/list"); }; $@ and unlink "$urpm->{cachedir}/partial/list"; } } else { $error = 1; $urpm->{error}(_("retrieve of source hdlist (or synthesis) failed")); } } #- build list file according to hdlist used. unless ($medium->{headers} || -s "$urpm->{cachedir}/partial/$medium->{hdlist}" > 32) { $error = 1; $urpm->{error}(_("no hdlist file found for medium \"%s\"", $medium->{name})); } #- make sure group and other does not have any access to this file. unless ($error) { #- sort list file contents according to id. my %list; if ($medium->{headers}) { #- rpm files have already been read (first pass), there is just a need to #- build list hash. foreach (@files) { /\/([^\/]*\.rpm)$/ or next; $list{$1} and $urpm->{error}(_("file [%s] already used in the same medium \"%s\"", $1, $medium->{name})), next; $list{$1} = "$prefix:/$_\n"; } } else { #- read first pass hdlist or synthesis, try to open as synthesis, if file #- is larger than 1MB, this is problably an hdlist else a synthesis. #- anyway, if one tries fails, try another mode. my @unresolved_before = grep { ! defined $urpm->{provides}{$_} } keys %{$urpm->{provides} || {}}; if (!$medium->{synthesis} || -s "$urpm->{cachedir}/partial/$medium->{hdlist}" > 262144) { ($medium->{start}, $medium->{end}) = $urpm->parse_hdlist("$urpm->{cachedir}/partial/$medium->{hdlist}", 1); if (defined $medium->{start} && defined $medium->{end}) { delete $medium->{synthesis}; } else { ($medium->{start}, $medium->{end}) = $urpm->parse_synthesis("$urpm->{cachedir}/partial/$medium->{hdlist}"); defined $medium->{start} && defined $medium->{end} and $medium->{synthesis} = 1; } } else { ($medium->{start}, $medium->{end}) = $urpm->parse_synthesis("$urpm->{cachedir}/partial/$medium->{hdlist}"); if (defined $medium->{start} && defined $medium->{end}) { $medium->{synthesis} = 1; } else { ($medium->{start}, $medium->{end}) = $urpm->parse_hdlist("$urpm->{cachedir}/partial/$medium->{hdlist}", 1); defined $medium->{start} && defined $medium->{end} and delete $medium->{synthesis}; } } unless (defined $medium->{start} && defined $medium->{end}) { $error = 1; $urpm->{error}(_("unable to parse hdlist file of \"%s\"", $medium->{name})); #- we will have to read back the current synthesis file unmodified. } unless ($error) { my @unresolved_after = grep { ! defined $urpm->{provides}{$_} } keys %{$urpm->{provides} || {}}; @unresolved_before == @unresolved_after or $urpm->{second_pass} = 1; if ($medium->{hdlist} ne 'list' && -s "$urpm->{cachedir}/partial/list") { local (*F, $_); open F, "$urpm->{cachedir}/partial/list"; while () { /\/([^\/]*\.rpm)$/ or next; $list{$1} and $urpm->{error}(_("file [%s] already used in the same medium \"%s\"", $1, $medium->{name})), next; $list{$1} = "$medium->{url}/$_"; } close F; } else { foreach ($medium->{start} .. $medium->{end}) { my $filename = $urpm->{depslist}[$_]->filename; $list{$filename} = "$medium->{url}/$filename\n"; } } } } #- check there is something found. %list or $error = 1, $urpm->{error}(_("nothing to write in list file for \"%s\"", $medium->{name})); unless ($error) { #- write list file. local *LIST; my $mask = umask 077; open LIST, ">$urpm->{cachedir}/partial/$medium->{list}" or $error = 1, $urpm->{error}(_("unable to write list file of \"%s\"", $medium->{name})); umask $mask; print LIST values %list; close LIST; #- check if at least something has been written into list file. -s "$urpm->{cachedir}/partial/$medium->{list}" > 32 or $error = 1, $urpm->{error}(_("nothing written in list file for \"%s\"", $medium->{name})); } } if ($error) { #- an error has occured for updating the medium, we have to remove tempory files. unlink "$urpm->{cachedir}/partial/$medium->{hdlist}"; unlink "$urpm->{cachedir}/partial/$medium->{list}"; #- read default synthesis (we have to make sure nothing get out of depslist). $urpm->{log}(_("examining synthesis file [%s]", "$urpm->{statedir}/synthesis.$medium->{hdlist}")); ($medium->{start}, $medium->{end}) = $urpm->parse_synthesis("$urpm->{statedir}/synthesis.$medium->{hdlist}"); unless (defined $medium->{start} && defined $medium->{end}) { $urpm->{error}(_("problem reading synthesis file of medium \"%s\"", $medium->{name})); $medium->{ignore} = 1; } } 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}"; $medium->{synthesis} and unlink "$urpm->{statedir}/synthesis.$medium->{hdlist}"; unlink "$urpm->{statedir}/$medium->{list}"; unless ($medium->{headers}) { rename("$urpm->{cachedir}/partial/$medium->{hdlist}", $medium->{synthesis} ? "$urpm->{statedir}/synthesis.$medium->{hdlist}" : "$urpm->{statedir}/$medium->{hdlist}") or system("mv", "$urpm->{cachedir}/partial/$medium->{hdlist}", $medium->{synthesis} ? "$urpm->{statedir}/synthesis.$medium->{hdlist}" : "$urpm->{statedir}/$medium->{hdlist}"); } rename("$urpm->{cachedir}/partial/$medium->{list}", "$urpm->{statedir}/$medium->{list}") or system("mv", "$urpm->{cachedir}/partial/$medium->{list}", "$urpm->{statedir}/$medium->{list}"); #- and create synthesis file associated. $medium->{modified_synthesis} = !$medium->{synthesis}; } } #- some unresolved provides may force to rebuild all synthesis, #- a second pass will be necessary. $urpm->{second_pass} and $urpm->unresolved_provides_clean; #- second pass consist of reading again synthesis or hdlist. foreach my $medium (@{$urpm->{media}}) { #- take care of modified medium only or all if all have to be recomputed. $medium->{ignore} and next; #- a modified medium is an invalid medium, we have to read back the previous hdlist #- or synthesis which has not been modified by first pass above. if ($medium->{headers} && !$medium->{modified}) { if ($urpm->{second_pass}) { $urpm->{log}(_("reading headers from medium \"%s\"", $medium->{name})); ($medium->{start}, $medium->{end}) = $urpm->parse_headers(dir => "$urpm->{cachedir}/headers", headers => $medium->{headers}, ); } $urpm->{log}(_("building hdlist [%s]", "$urpm->{statedir}/$medium->{hdlist}")); #- finish building operation of hdlist. $urpm->build_hdlist(start => $medium->{start}, end => $medium->{end}, dir => "$urpm->{cachedir}/headers", hdlist => "$urpm->{statedir}/$medium->{hdlist}", ); #- synthesis need to be created for sure, since the medium has been built from rpm files. $urpm->build_synthesis(start => $medium->{start}, end => $medium->{end}, synthesis => "$urpm->{statedir}/synthesis.$medium->{hdlist}", ); $urpm->{log}(_("built hdlist synthesis file for medium \"%s\"", $medium->{name})); #- keep in mind we have modified database, sure at this point. $urpm->{modified} = 1; } elsif ($medium->{synthesis}) { if ($urpm->{second_pass}) { $urpm->{log}(_("examining synthesis file [%s]", "$urpm->{statedir}/synthesis.$medium->{hdlist}")); ($medium->{start}, $medium->{end}) = $urpm->parse_synthesis("$urpm->{statedir}/synthesis.$medium->{hdlist}"); } } else { if ($urpm->{second_pass}) { $urpm->{log}(_("examining hdlist file [%s]", "$urpm->{statedir}/$medium->{hdlist}")); ($medium->{start}, $medium->{end}) = $urpm->parse_hdlist("$urpm->{statedir}/$medium->{hdlist}", 1); } #- check if synthesis file can be built. if (($urpm->{second_pass} || $medium->{modified_synthesis}) && !$medium->{modified}) { $urpm->build_synthesis(start => $medium->{start}, end => $medium->{end}, synthesis => "$urpm->{statedir}/synthesis.$medium->{hdlist}", ); $urpm->{log}(_("built hdlist synthesis file for medium \"%s\"", $medium->{name})); #- keep in mind we have modified database, sure at this point. $urpm->{modified} = 1; } } } #- clean headers cache directory to remove everything that is no more #- usefull according to depslist used. if ($urpm->{modified}) { if ($options{noclean}) { local (*D, $_); my %headers; opendir D, "$urpm->{cachedir}/headers"; while (defined($_ = readdir D)) { /^([^\/]*-[^-]*-[^-]*\.[^\.]*)(?::\S*)?$/ and $headers{$1} = $_; } closedir D; $urpm->{log}(_("found %d headers in cache", scalar(keys %headers))); foreach (@{$urpm->{depslist}}) { delete $headers{$_->fullname}; } $urpm->{log}(_("removing %d obsolete headers in cache", scalar(keys %headers))); foreach (values %headers) { unlink "$urpm->{cachedir}/headers/$_"; } } #- this file is written in any cases. $urpm->write_config(); } #- now everything is finished. system("sync"); #- release lock on database. flock LOCK_FILE, $LOCK_UN; close LOCK_FILE; } #- clean params and depslist computation zone. sub clean { my ($urpm) = @_; $urpm->{depslist} = []; $urpm->{provides} = {}; $urpm->{names} = {}; foreach (@{$urpm->{media} || []}) { delete $_->{start}; delete $_->{end}; } } #- find used mount point from a pathname, use a optional mode to allow #- filtering according the next operation (mount or umount). sub find_mntpoints { my ($urpm, $dir, $mode) = @_; #- fast mode to check according to next operation. $mode eq 'mount' && -e $dir and return; $mode eq 'umount' && ! -e $dir and return; #- really check and find mount points here. my ($fdir, $pdir, $v, %fstab, @mntpoints) = $dir; local (*F, $_); #- read /etc/fstab and check for existing mount point. open F, "/etc/fstab"; while () { my ($device, $mntpoint, $fstype, $options) = /^\s*(\S+)\s+(\/\S+)\s+(\S+)\s+(\S+)/ or next; $mntpoint =~ s,/+,/,g; $mntpoint =~ s,/$,,; $fstab{$mntpoint} = 0; if ($mode eq 'device') { if ($fstype eq 'supermount') { $options =~ /^(?:.*[\s,])?dev=([^\s,]+)/ and $fstab{$mntpoint} = $1; } elsif ($device eq 'none') { next; } else { $fstab{$mntpoint} = $device; } } } open F, "/etc/mtab"; while () { my ($device, $mntpoint, $fstype, $options) = /^\s*(\S+)\s+(\/\S+)\s+(\S+)\s+(\S+)/ or next; $mntpoint =~ s,/+,/,g; $mntpoint =~ s,/$,,; $fstab{$mntpoint} = 1; if ($mode eq 'device') { if ($fstype eq 'supermount') { $options =~ /^(?:.*[\s,])?dev=([^\s,]+)/ and $fstab{$mntpoint} = $1; } elsif ($device eq 'none') { next; } else { $fstab{$mntpoint} = $device; } } } 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 possible mount point. foreach (split '/', $fdir) { length($_) or next; $pdir .= "/$_"; $pdir =~ s,/+,/,g; $pdir =~ s,/$,,; if (exists $fstab{$pdir}) { $mode eq 'mount' && ! $fstab{$pdir} and push @mntpoints, $pdir; $mode eq 'umount' && $fstab{$pdir} and unshift @mntpoints, $pdir; $mode eq 'device' and push @mntpoints, $pdir, $fstab{$pdir}; } } @mntpoints; } #- reduce pathname by removing /.. each time it appears (or . too). sub reduce_pathname { my ($url) = @_; #- take care if this is a true url and not a simple pathname. my ($host, $dir) = $url =~ /([^:\/]*:\/\/[^\/]*\/)?(.*)/; #- remove any multiple /s or trailing /. #- then split all components of pathname. $dir =~ s/\/+/\//g; $dir =~ s/\/$//; my @paths = split '/', $dir; #- reset $dir, recompose it, and clean trailing / added by algorithm. $dir = ''; foreach (@paths) { if ($_ eq '..') { $dir =~ s/([^\/]+)\/$// or $dir .= "../"; } elsif ($_ ne '.') { $dir .= "$_/"; } } $dir =~ s/\/$//; $host . $dir; } #- check for necessity of mounting some directory to get access sub try_mounting { my ($urpm, $dir) = @_; $dir = reduce_pathname($dir); foreach ($urpm->find_mntpoints($dir, 'mount')) { $urpm->{log}(_("mounting %s", $_)); `mount '$_' 2>/dev/null`; } -e $dir; } sub try_umounting { my ($urpm, $dir) = @_; $dir = reduce_pathname($dir); foreach ($urpm->find_mntpoints($dir, 'umount')) { $urpm->{log}(_("unmounting %s", $_)); `umount '$_' 2>/dev/null`; } ! -e $dir; } #- relocate depslist array id to use only the most recent packages, #- reorder info hashes to give only access to best packages. sub relocate_depslist_provides { my ($urpm, %options) = @_; my $relocated_entries = $urpm->relocate_depslist; $urpm->{log}($relocated_entries ? _("relocated %s entries in depslist", $relocated_entries) : _("no entries relocated in depslist")); $relocated_entries; } #- register local packages for being installed, keep track of source. sub register_rpms { my ($urpm, @files) = @_; my ($start, $id, $error); #- examine each rpm and build the depslist for them using current #- depslist and provides environment. $start = @{$urpm->{depslist}}; foreach (@files) { /(.*\/)?[^\/]*\.rpm$/ or $error = 1, $urpm->{error}(_("invalid rpm file name [%s]", $_)), next; -r $_ or $error = 1, $urpm->{error}(_("unable to access rpm file [%s]", $_)), next; ($id, undef) = $urpm->parse_rpm($_); my $pkg = $urpm->{depslist}[$id]; $pkg or $urpm->{error}(_("unable to register rpm file")), next; $urpm->{source}{$id} = $1 ? $_ : "./$_"; } $error and $urpm->{fatal}(1, _("error registering local packages")); $start <= $id ? ($start, $id) : (); } #- search packages registered by their name by storing their id into packages hash. sub search_packages { my ($urpm, $packages, $names, %options) = @_; my (%exact, %exact_a, %exact_ra, %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. unless ($options{fuzzy}) { my $pkg = $urpm->{names}{$v}; if ($pkg && defined $pkg->id && ($options{src} ? $pkg->arch eq 'src' : $pkg->arch ne 'src')) { $exact{$v} = $pkg->id; next; } } my $qv = quotemeta $v; if ($options{use_provides}) { unless ($options{fuzzy}) { #- try to search through provides. if (my @l = grep { defined $_ } map { $_ && ($options{src} ? $_->arch eq 'src' : $_->arch ne 'src') && $_->id || undef } map { $urpm->{depslist}[$_] } keys %{$urpm->{provides}{$v} || {}}) { #- we assume that if the there is at least one package providing the resource exactly, #- this should be the best ones that is described. $exact{$v} = join '|', @l; next; } } foreach (keys %{$urpm->{provides}}) { #- search through provides to find if a provide match this one. #- but manages choices correctly (as a provides may be virtual or #- multiply defined. if (/$qv/) { my @list = grep { defined $_ } map { my $pkg = $urpm->{depslist}[$_]; $pkg && ($options{src} ? $pkg->arch eq 'src' : $pkg->arch ne 'src') ? $pkg->id : undef } keys %{$urpm->{provides}{$_} || {}}; @list > 0 and push @{$found{$v}}, join '|', @list; } if (/$qv/i) { my @list = grep { defined $_ } map { my $pkg = $urpm->{depslist}[$_]; $pkg && ($options{src} ? $pkg->arch eq 'src' : $pkg->arch ne 'src') ? $pkg->id : undef } keys %{$urpm->{provides}{$_} || {}}; @list > 0 and push @{$found{$v}}, join '|', @list; } } } foreach my $id (0 .. $#{$urpm->{depslist}}) { my $pkg = $urpm->{depslist}[$id]; ($options{src} ? $pkg->arch eq 'src' : $pkg->is_arch_compat) or next; my $pack_ra = $pkg->name . '-' . $pkg->version; my $pack_a = "$pack_ra-" . $pkg->release; my $pack = "$pack_a." . $pkg->arch; unless ($options{fuzzy}) { if ($pack eq $v) { $exact{$v} = $id; next; } elsif ($pack_a eq $v) { push @{$exact_a{$v}}, $id; next; } elsif ($pack_ra eq $v) { push @{$exact_ra{$v}}, $id; next; } } $pack =~ /$qv/ and push @{$found{$v}}, $id; $pack =~ /$qv/i and push @{$foundi{$v}}, $id; } } my $result = 1; foreach (@$names) { if (defined $exact{$_}) { $packages->{$exact{$_}} = undef; } else { #- at this level, we need to search the best package given for a given name, #- always prefer already found package. my %l; foreach (@{$exact_a{$_} || $exact_ra{$_} || $found{$_} || $foundi{$_} || []}) { my $pkg = $urpm->{depslist}[$_]; push @{$l{$pkg->name}}, $pkg; } if (values(%l) == 0) { $urpm->{error}(_("no package named %s", $_)); $result = 0; } elsif (values(%l) > 1 && !$options{all}) { $urpm->{error}(_("The following packages contain %s: %s", $_, join(' ', keys %l))); $result = 0; } else { foreach (values %l) { my $best; foreach (@$_) { if ($best && $best != $_) { $_->compare_pkg($best) > 0 and $best = $_; } else { $best = $_; } } $packages->{$best->id} = undef; } } } } #- return true if no error have been encoutered, else false. $result; } #- filter minimal list, upgrade packages only according to rpm requires #- satisfied, remove upgrade for package already installed or with a better #- version, try to upgrade to minimize upgrade errors. #- all additional package selected have a true value. sub filter_packages_to_upgrade { my ($urpm, $db, $packages, $select_choices, %options) = @_; my ($id, %track, %track_requires, %installed, %selected, %conflicts); my @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 dependencies. #- allow iteration over a modifying list. while (defined($id = shift @packages)) { $id =~ /\|/ and delete $packages->{$id}, $id = [ split '\|', $id ]; #- get back choices... if (ref $id) { my (@forced_selection, @selection); #- at this point we have almost only choices to resolves. #- but we have to check if one package here is already selected #- previously, if this is the case, use it instead. #- if a choice is proposed with package already installed (this is the case for #- a provide with a lot of choices, we have to filter according to those who #- are installed). foreach (@$id) { my $pkg = $urpm->{depslist}[$_]; $pkg->arch eq 'src' and return; my $count = $options{keep_alldeps} || exists $installed{$pkg->id} ? 0 : $db->traverse_tag('name', [ $pkg->name ], sub { my ($p) = @_; $installed{$pkg->id} ||= $pkg->compare_pkg($p) <= 0; }); if (exists $packages->{$_} || $count > 0) { $installed{$pkg->id} or push @forced_selection, $_; } else { push @selection, $_; } } #- propose the choice to the user now, or select the best one (as it is supposed to be). @selection = @forced_selection ? @forced_selection : $select_choices ? (@selection > 1 ? ($select_choices->($urpm, undef, @selection)) : ($selection[0])) : (join '|', @selection); foreach (@selection) { unless (exists $packages->{$_}) { /\|/ or unshift @packages, $_; $packages->{$_} = 1; } } next; } my $pkg = $urpm->{depslist}[$id]; defined $pkg->id or next; #- id has been removed for package that only exists on some arch. #- search for package that will be upgraded, and check the difference #- of provides to see if something will be altered and need to be upgraded. #- this is bogus as it only take care of == operator if any. #- defining %provides here could slow the algorithm but it solves multi-pass #- where a provides is A and after A == version-release, when A is already #- installed. my (%diff_provides, %provides); if ($pkg->arch ne 'src') { my @upgraded; foreach ($pkg->name, $pkg->obsoletes) { if (my ($n, $o, $v) = /^([^\s\[]*)(?:\[\*\])?(?:\s+|\[)?([^\s\]]*)\s*([^\s\]]*)/) { $db->traverse_tag('name', [ $n ], sub { my ($p) = @_; eval($p->compare($v) . $o . 0) or return; $options{track} and $p->pack_header, push @upgraded, $p; foreach ($p->provides) { s/\[\*\]//; s/\[([^\]]*)\]/ $1/; $diff_provides{$_} = $p->fullname; } }); } } $options{track} and $track{$pkg->id}{upgraded} = \@upgraded; foreach ($pkg->provides) { s/\[\*\]//; s/\[([^\]]*)\]/ $1/; delete $diff_provides{$_}; } foreach (keys %diff_provides) { #- analyse the difference in provides and select other package. if (my ($n, $o, $v) = /^(\S*)\s*(\S*)\s*(\S*)/) { my $check = sub { my ($p) = @_; my ($needed, $satisfied) = (0, 0); foreach ($p->requires) { if (my ($pn, $po, $pv) = /^([^\s\[]*)(?:\[\*\])?(?:\s+|\[)?([^\s\]]*)\s*([^\s\]]*)/) { if ($po || $o) { $pn eq $n && $pn eq $pkg->name or next; ++$needed; eval($pkg->compare($pv) . $po . 0) or next; #- an existing provides (propably the one examined) is satisfying the underlying. ++$satisfied; } else { $pn eq $n or next; #- a property has been removed since in diff_provides. ++$needed; } } } #- check if the package need to be updated because it #- losts some of its requires regarding the current diff_provides. if ($needed > $satisfied) { $selected{$p->name} ||= undef; if ($options{track}) { $p->pack_header; push @{$track{$pkg->id}{diff_provides} ||= []}, $p; } } }; $db->traverse_tag('whatrequires', [ $n ], $check); } } $selected{$pkg->name} ||= undef; } #- iterate over requires of the packages, register them. foreach ($pkg->requires) { if (my ($n, $o, $v) = /^([^\s\[]*)(?:\[\*\])?(?:\s+|\[)?([^\s\]]*)\s*([^\s\]]*)/) { exists $provides{$_} and next; #- if the provides is not found, it will be resolved at next step, else #- it will be resolved by searching the rpm database. $provides{$_} ||= undef; unless ($options{keep_alldeps}) { my $check_pkg = sub { my ($p) = @_; exists $selected{$p->name} and return; $o and $n eq $p->name || return; eval($p->compare($v) . $o . 0) or return; $provides{$_} = $p->fullname; }; $db->traverse_tag($n =~ m|^/| ? 'path' : 'whatprovides', [ $n ], $check_pkg); } $options{track} and $track_requires{$_}{$pkg->id} = $_; } } #- examine conflicts and try to resolve them. #- if there is a conflicts with a too old version, it need to be upgraded. #- if there is a provides (by using a obsoletes on it too), examine obsolete (provides) too. foreach ($pkg->conflicts) { if (my ($n, $o, $v) = /^([^\s\[]*)(?:\[\*\])?(?:\s+|\[)?([^\s\]]*)\s*([^\s\]]*)/) { my $check_pkg = sub { my ($p) = @_; $o and $n eq $p->name || return; eval($p->compare($v) . $o . 0) or return; $conflicts{$p->fullname} = 1; $selected{$p->name} ||= undef; if ($options{track}) { $p->pack_header; push @{$track{$pkg->id}{conflicts} ||= []}, $p; } }; $db->traverse_tag($n =~ m|^/| ? 'path' : 'whatprovides', [ $n ], $check_pkg); foreach my $id (keys %{$urpm->{provides}{$n} || {}}) { my $p = $urpm->{depslist}[$id]; $p->arch eq 'src' and next; $o and $n eq $p->name || next; eval($p->compare($v) . $o . 0) or next; $conflicts{$p->fullname} ||= 0; } } } #- at this point, all unresolved provides (requires) should be fixed by #- provides files, try to minimize choice at this level. foreach (keys %provides, grep { !$selected{$_} } keys %selected) { my (%pre_choices, @pre_choices, @choices, @upgradable_choices, %choices_id); if (my ($n, $o, $v) = /^([^\s\[]*)(?:\[\*\])?(?:\s+|\[)?([^\s\]]*)\s*([^\s\]]*)/) { $provides{$_} and next; foreach my $id (keys %{$urpm->{provides}{$n} || {}}) { my $pkg = $urpm->{depslist}[$id]; exists $conflicts{$pkg->fullname} and next; $pkg->arch eq 'src' and next; $selected{$n} || $selected{$pkg->name} and %pre_choices=(), last; #- check if a unsatisfied selection on a package is needed, #- which need a obsolete on a package with different name or #- a package with the given name. #- if an obsolete is given, it will be satisfied elsewhere. CHECK TODO if ($n ne $pkg->name) { unless (exists $selected{$n}) { #- a virtual provides exists with a specific version and maybe release. #- try to resolve. foreach ($pkg->provides) { if (my ($pn, $po, $pv) = /^([^\s\[]*)(?:\[\*\])?(?:\s+|\[)?([^\s\]]*)\s*([^\s\]]*)/) { $pn eq $n or next; my $no = $po eq '==' ? $o : $po; #- CHECK TODO ? #TODO (!$pv || !$v || eval(rpmtools::version_compare($pv, $v) . $no . 0)) && #TODO (!$pr || !$r || rpmtools::version_compare($pv, $v) != 0 || #TODO eval(rpmtools::version_compare($pr, $r) . $no . 0)) or next; push @{$pre_choices{$pkg->name}}, $pkg; } } } } else { eval($pkg->compare($v) . $o . 0) or next; push @{$pre_choices{$pkg->name}}, $pkg; } } } foreach (values %pre_choices) { #- there is at least one element in each list of values. if (@$_ == 1) { push @pre_choices, $_->[0]; } else { #- take the best one, according to id used. my $chosen_pkg; foreach my $id (%$packages) { my $candidate_pkg = $urpm->{depslist}[$id]; $candidate_pkg->name eq $pkg->name or next; foreach my $pkg (@$_) { $pkg == $candidate_pkg and $chosen_pkg = $pkg, last; } } $chosen_pkg ||= $urpm->{names}{$_->[0]->name}; #- at least take the best normally used. push @pre_choices, $chosen_pkg; } } foreach my $pkg (@pre_choices) { push @choices, $pkg; $pkg->arch eq 'src' and return; unless ($options{keep_alldeps} || exists $installed{$pkg->id}) { $db->traverse_tag('name', [ $pkg->name ], sub { my ($p) = @_; $installed{$pkg->id} ||= $pkg->compare_pkg($p) <= 0; }); } $installed{$pkg->id} and delete $packages->{$pkg->id}; exists $installed{$pkg->id} and push @upgradable_choices, $pkg; } foreach my $pkg (@pre_choices) { if (exists $packages->{$pkg->id} || $installed{$pkg->id}) { #- the package is already selected, or installed with a better version and release. @choices = @upgradable_choices = (); last; } } @upgradable_choices > 0 and @choices = @upgradable_choices; $choices_id{$_->id} = $_ foreach @choices; if (keys(%choices_id) == 1) { my ($id) = keys(%choices_id); $selected{$choices_id{$id}->name} = 1; unless ($packages->{$id}) { $packages->{$id} = 1; if ($options{track} && $track_requires{$_}) { foreach my $deps (keys %{$track_requires{$_}}) { $track{$deps}{requires}{$id} = $_; } } } unshift @packages, $id; } elsif (keys(%choices_id) > 1) { push @packages, [ sort { $a <=> $b } keys %choices_id ]; if ($options{track} && $track_requires{$_}) { foreach my $deps (keys %{$track_requires{$_}}) { $track{$deps}{requires}{join '|', sort { $a <=> $b } keys %choices_id} = $_; } } } } } #- rpm db will be closed automatically on destruction of $db. \%track; } #- get out of package that should not be upgraded. sub deselect_unwanted_packages { my ($urpm, $packages, %options) = @_; local ($_, *F); open F, $urpm->{skiplist}; while () { chomp; s/#.*$//; s/^\s*//; s/\s*$//; foreach (keys %{$urpm->{provides}{$_} || {}}) { my $pkg = $urpm->{depslist}[$_] or next; $pkg->arch eq 'src' and next; #- never ignore source package. $options{force} || (exists $packages->{$pkg->id} && defined $packages->{$pkg->id}) and delete $packages->{$pkg->id}; } } close F; } #- select source for package selected. #- according to keys given in the packages hash. #- return a list of list containing the source description for each rpm, #- match exactly the number of medium registered, ignored medium always #- have a null list. sub get_source_packages { my ($urpm, $packages) = @_; my ($id, $error, %local_sources, @list, @local_to_removes, %fullname2id, %file2fullnames); local (*D, *F, $_); #- build association hash to retrieve id and examine all list files. foreach (keys %$packages) { my $p = $urpm->{depslist}[$_]; if ($urpm->{source}{$_}) { $local_sources{$_} = $urpm->{source}{$_}; } else { $fullname2id{$p->fullname} = $_; } } #- examine each medium to search for packages. #- now get rpm file name in hdlist to match list file. foreach my $medium (@{$urpm->{media} || []}) { foreach ($medium->{start} .. $medium->{end}) { my $pkg = $urpm->{depslist}[$_]; $file2fullnames{($pkg->filename =~ /(.*)\.rpm$/ && $1) || $pkg->fullname}{$pkg->fullname} = undef; } } #- examine the local repository, which is trusted. opendir D, "$urpm->{cachedir}/rpms"; while (defined($_ = readdir D)) { if (/([^\/]*)\.rpm/) { if (-s "$urpm->{cachedir}/rpms/$1.rpm") { if (keys(%{$file2fullnames{$1} || {}}) > 1) { $urpm->{error}(_("there are multiple packages with the same rpm filename \"%s\""), $1); next; } elsif (keys(%{$file2fullnames{$1} || {}}) == 1) { my ($fullname) = keys(%{$file2fullnames{$1} || {}}); if (defined($id = delete $fullname2id{$fullname})) { $local_sources{$id} = "$urpm->{cachedir}/rpms/$1.rpm"; } else { push @local_to_removes, "$urpm->{cachedir}/rpms/$1.rpm"; } } } else { #- this is an invalid file in cache, remove it and ignore it. unlink "$urpm->{cachedir}/rpms/$1.rpm"; } } #- no error on unknown filename located in cache (because .listing) } closedir D; foreach my $medium (@{$urpm->{media} || []}) { my %sources; if (-r "$urpm->{statedir}/$medium->{list}" && !$medium->{ignore}) { open F, "$urpm->{statedir}/$medium->{list}"; while () { if (/(.*)\/([^\/]*)\.rpm$/) { if (keys(%{$file2fullnames{$2} || {}}) > 1) { $urpm->{error}(_("there are multiple packages with the same rpm filename \"%s\""), $2); next; } elsif (keys(%{$file2fullnames{$2} || {}}) == 1) { my ($fullname) = keys(%{$file2fullnames{$2} || {}}); defined($id = delete $fullname2id{$fullname}) and $sources{$id} = "$1/$2.rpm"; } } else { chomp; $error = 1; $urpm->{error}(_("unable to parse correctly [%s] on value \"%s\"", "$urpm->{statedir}/$medium->{list}", $_)); last; } } close F; } push @list, \%sources; } #- examine package list to see if a package has not been found. foreach (keys %fullname2id) { $error = 1; $urpm->{error}(_("package %s is not found.", $_)); } $error ? () : ( \%local_sources, \@list, \@local_to_removes ); } #- download package that may need to be downloaded. #- make sure header are available in the appropriate directory. #- change location to find the right package in the local #- filesystem for only one transaction. #- try to mount/eject removable media here. #- return a list of package ready for rpm. sub download_source_packages { my ($urpm, $local_sources, $list, $force_local, $ask_for_medium) = @_; my (%sources, @distant_sources, %media, %removables); #- make sure everything is correct on input... @{$urpm->{media}} == @$list or return; #- examine if given medium is already inside a removable device. my $check_notfound = sub { my ($id, $dir) = @_; $dir and $urpm->try_mounting($dir); if (!$dir || -e $dir) { foreach (values %{$list->[$id]}) { /^(removable_?[^_:]*|file):\/(.*\/([^\/]*))/ or next; unless ($dir) { $dir = $2; $urpm->try_mounting($dir); } -r $2 or return 1; } } else { return 2; } return 0; }; #- removable media have to be examined to keep mounted the one that has #- more package than other (size is better ?). my $examine_removable_medium = sub { my ($id, $device, $copy) = @_; my $medium = $urpm->{media}[$id]; $media{$id} = undef; if (my ($prefix, $dir) = $medium->{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. while ($check_notfound->($id, $dir)) { $ask_for_medium or $urpm->{fatal}(4, _("medium \"%s\" is not selected", $medium->{name})); $urpm->try_umounting($dir); system("eject", $device); $ask_for_medium->($medium->{name}, $medium->{removable}) or $urpm->{fatal}(4, _("medium \"%s\" is not selected", $medium->{name})); } if (-e $dir) { my @removable_sources; while (my ($i, $url) = each %{$list->[$id]}) { $url =~ /^(removable[^:]*|file):\/(.*\/([^\/]*))/ or next; -r $2 or $urpm->{error}(_("unable to read rpm file [%s] from medium \"%s\"", $2, $medium->{name})); if ($copy) { push @removable_sources, $2; $sources{$i} = "$urpm->{cachedir}/rpms/$3"; } else { $sources{$i} = $2; } } if (@removable_sources) { system("cp", "-a", @removable_sources, "$urpm->{cachedir}/rpms"); } } else { $urpm->{error}(_("medium \"%s\" is not selected", $medium->{name})); } } else { #- we have a removable device that is not removable, well... $urpm->{error}(_("incoherent medium \"%s\" marked removable but not really", $medium->{name})); } }; foreach (0..$#$list) { values %{$list->[$_]} or next; my $medium = $urpm->{media}[$_]; #- examine non removable device but that may be mounted. if ($medium->{removable}) { push @{$removables{$medium->{removable}} ||= []}, $_; } elsif (my ($prefix, $dir) = $medium->{url} =~ /^(removable[^:]*|file):\/(.*)/) { -e $dir || $urpm->try_mounting($dir) or $urpm->{error}(_("unable to access medium \"%s\"", $medium->{name})), next; } } foreach my $device (keys %removables) { #- here we have only removable device. #- if more than one media use this device, we have to sort #- needed package to copy first the needed rpms files. if (@{$removables{$device}} > 1) { my @sorted_media = sort { values %{$list->[$a]} <=> values %{$list->[$b]} } @{$removables{$device}}; #- check if a removable device is already mounted (and files present). if (my ($already_mounted_medium) = grep { !$check_notfound->($_) } @sorted_media) { @sorted_media = grep { $_ ne $already_mounted_medium } @sorted_media; unshift @sorted_media, $already_mounted_medium; } #- mount all except the biggest one. foreach (@sorted_media[0 .. $#sorted_media-1]) { $examine_removable_medium->($_, $device, 'copy'); } #- now mount the last one... $removables{$device} = [ $sorted_media[-1] ]; } #- mount the removable device, only one or the important one. $examine_removable_medium->($removables{$device}[0], $device); } #- get back all ftp and http accessible rpms file into the local cache #- if necessary (as used by checksig or any other reasons). foreach (0..$#$list) { exists $media{$_} and next; values %{$list->[$_]} or next; while (my ($i, $url) = each %{$list->[$_]}) { if ($url =~ /^(removable[^:]*|file):\/(.*)/) { $sources{$i} = $2; } elsif ($url =~ /^([^:]*):\/(.*\/([^\/]*))/) { if ($force_local) { push @distant_sources, $url; $sources{$i} = "$urpm->{cachedir}/rpms/$3"; } else { $sources{$i} = $url; } } else { $urpm->{error}(_("malformed input: [%s]", $url)); } } } @distant_sources and eval { $urpm->{log}(_("retrieving rpms files...")); foreach (map { m|([^:]*://[^/:\@]*:)[^/:\@]*(\@.*)| ? "$1xxxx$2" : $_ } @distant_sources) { $urpm->{log}(" $_") ; } $urpm->{sync}("$urpm->{cachedir}/rpms", @distant_sources); $urpm->{log}(_("...retrieving done")); }; $@ and $urpm->{log}(_("...retrieving failed: %s", $@)); #- return the hash of rpm file that have to be installed, they are all local now. %$local_sources, %sources; } #- extract package that should be installed instead of upgraded, #- sources is a hash of id -> source rpm filename. sub extract_packages_to_install { my ($urpm, $sources) = @_; my %inst; local ($_, *F); open F, $urpm->{instlist}; while () { chomp; s/#.*$//; s/^\s*//; s/\s*$//; foreach (keys %{$urpm->{provides}{$_} || {}}) { my $pkg = $urpm->{depslist}[$_] or next; #- some package with specific naming convention to avoid upgrade problem #- should not be taken into account here. #- these package have version=1 and release=1mdk, and name contains version and release. $pkg->version eq '1' && $pkg->release eq '1mdk' && $pkg->name =~ /^.*-[^\-]*mdk$/ and next; exists $sources->{$pkg->id} and $inst{$pkg->id} = delete $sources->{$pkg->id}; } } close F; \%inst; } sub select_packages_to_upgrade { my ($urpm, $db, $packages, $remove_packages, $keep_files, %options) = @_; #- used for package that are not correctly updated. #- should only be used when nothing else can be done correctly. my %upgradeNeedRemove = ( #'libstdc++' => 1, #'compat-glibc' => 1, #'compat-libs' => 1, ); #- installed flag on id. my %installed; #- help removing package which may have different release numbering my %toRemove; #- help searching package to upgrade in regard to already installed files. my %installedFilesForUpgrade; #- help keeping memory by this set of package that have been obsoleted. my %obsoletedPackages; #- select packages which obseletes other package, obselete package are not removed, #- should we remove them ? this could be dangerous ! foreach my $pkg (@{$urpm->{depslist}}) { defined $pkg->id && $pkg->arch ne 'src' or next; foreach ($pkg->obsoletes) { #- take care of flags and version and release if present if (my ($n,$o,$v) = /^([^\s\[]*)(?:\[\*\])?(?:\s+|\[)?([^\s\]]*)\s*([^\s\]]*)/) { my $obsoleted = 0; my $check_obsoletes = sub { my ($p) = @_; eval($p->compare($v) . $o . 0) or return; ++$obsoleted; }; $db->traverse_tag("name", [ $n ], $check_obsoletes); if ($obsoleted > 0) { $urpm->{log}(_("selecting %s using obsoletes", $pkg->fullname)); $obsoletedPackages{$n} = undef; $packages->{$pkg->id} = undef; } } } } #- mark all files which are not in /dev or /etc/rc.d/ for packages which are already installed #- but which are not in the packages list to upgrade. #- the 'installed' property will make a package unable to be selected, look at select. $db->traverse(sub { my ($p) = @_; my $otherPackage = $p->release !~ /mdk\w*$/ && ($p->name.'-'.$p->version.'-'.$p->release); my $pkg = $urpm->{names}{$p->name}; if ($pkg) { if ($p->compare_pkg($pkg) >= 0) { if ($otherPackage && $p->compare($pkg->version) <= 0) { $toRemove{$otherPackage} = 0; $packages->{$pkg->id} = undef; $urpm->{log}(_("removing %s to upgrade to %s ... since it will not be updated otherwise", $otherPackage, $pkg->name.'-'.$pkg->version.'-'.$pkg->release)); } else { $installed{$pkg->id} = undef; } } elsif ($upgradeNeedRemove{$pkg->name}) { my $otherPackage = $p->name.'-'.$p->version.'-'.$p->release; $toRemove{$otherPackage} = 0; $packages->{$pkg->id} = undef; $urpm->{log}(_("removing %s to upgrade to %s ... since it will not upgrade correctly!", $otherPackage, $pkg->name.'-'.$pkg->version.'-'.$pkg->release)); } } else { if (exists $obsoletedPackages{$p->name}) { @installedFilesForUpgrade{$p->upgrade_files} = (); } } }); #- find new packages to upgrade. foreach my $pkg (@{$urpm->{depslist}}) { defined $pkg->id && $pkg->arch ne 'src' or next; my $skipThis = 0; my $count = $db->traverse_tag("name", [ $pkg->name ], sub { $skipThis ||= exists $installed{$pkg->id}; }); #- skip if not installed (package not found in current install). $skipThis ||= ($count == 0); #- select the package if it is already installed with a lower version or simply not installed. unless ($skipThis) { my $cumulSize; $packages->{$pkg->id} = undef; #- keep in mind installed files which are not being updated. doing this costs in #- execution time but use less memory, else hash all installed files and unhash #- all file for package marked for upgrade. $db->traverse_tag("name", [ $pkg->name ], sub { my ($p) = @_; @installedFilesForUpgrade{$p->upgrade_files} = (); }); foreach ($pkg->files) { delete $installedFilesForUpgrade{$_}; } } } #- unmark all files for all packages marked for upgrade. it may not have been done above #- since some packages may have been selected by depsList. foreach my $pkg (@{$urpm->{depslist}}) { defined $pkg->id && $pkg->arch ne 'src' or next; if (exists $packages->{$pkg->id}) { foreach ($pkg->files) { delete $installedFilesForUpgrade{$_}; } } } #- select packages which contains marked files, then unmark on selection. #- a special case can be made here, the selection is done only for packages #- requiring locales if the locales are selected. #- another special case are for devel packages where fixes over the time has #- made some files moving between the normal package and its devel couterpart. #- if only one file is affected, no devel package is selected. foreach my $pkg (@{$urpm->{depslist}}) { defined $pkg->id && $pkg->arch ne 'src' or next; unless (exists $packages->{$pkg->id}) { my $toSelect = 0; foreach ($pkg->upgrade_files) { delete $installedFilesForUpgrade{$_} and ++$toSelect; } if ($toSelect) { if ($toSelect <= 1 && $pkg->name =~ /-devel/) { $urpm->{log}(_("avoid selecting %s as not enough files will be updated", $pkg->fullname)); } else { #- default case is assumed to allow upgrade. my @deps = grep { $_ } map { $urpm->{names}{$_} } grep { /locales-/ } $pkg->requires_nosense; if (@deps == 0 || @deps > 0 && (grep { ! exists $packages->{$pkg->id} && ! exists $installed{$_->{id}} } @deps) == 0) { $urpm->{log}(_("selecting %s by selection on files", $pkg->name)); $packages->{$pkg->id} = undef; } else { $urpm->{log}(_("avoid selecting %s as its locales language is not already selected", $pkg->fullname)); } } } } } #- clean memory... %installedFilesForUpgrade = (); #- clean false value on toRemove. delete $toRemove{''}; #- get filenames that should be saved for packages to remove. #- typically config files, but it may broke for packages that #- are very old when compabilty has been broken. #- but new version may saved to .rpmnew so it not so hard ! if ($keep_files && keys %toRemove) { $db->traverse(sub { my ($p) = @_; my $otherPackage = $p->name.'-'.$p->version.'-'.$p->release; if (exists $toRemove{$otherPackage}) { @{$keep_files}{$p->conf_files} = (); } }); } } 1;