diff options
Diffstat (limited to 'urpmq')
| -rwxr-xr-x | urpmq | 324 |
1 files changed, 324 insertions, 0 deletions
@@ -0,0 +1,324 @@ +#!/usr/bin/perl + +#- 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. + +#- this program is based upon urpmi. + +#use strict qw(subs vars refs); +use rpmtools; + +#- default options. +my $query = {}; +my $datadir = "/var/lib/urpmi"; +my $confdir = "/etc/urpmi"; + +my $depslist = "$datadir/depslist.ordered"; +my $provides = "$datadir/provides"; +my $compss = "$datadir/compss"; + +my @files; +my @names; + +my %I18N; +load_po(); + +sub usage { + die(_("usage: urpmq [-h] [-d] [-u] [-g] [-v] [-r] package_name|rpm_file [package_names|rpm_files...]\n")); +} + +#- parse arguments list. +my @nextargv; +for (@ARGV) { + /^--help$/ and do { usage; next }; + /^-(.*)$/ and do { foreach (split //, $1) { + /[\?h]/ and do { usage; next }; + /d/ and do { $query->{deps} = 1; next }; + /u/ and do { $query->{upgrade} = 1; next }; + /g/ and do { $query->{group} = 1; next }; + /v/ and do { $query->{version} = 1; next }; + /r/ and do { $query->{release} = 1; next }; + die "urpmq: unknown option \"-$1\", check usage with --help\n"; } next }; + @nextargv and do { my $r = shift @nextargv; $r and $$r = $_; next }; + /\.rpm$/ and do { -r $_ or print STDERR "urpmq: cannot read rpm file \"$_\"\n", next; + push @files, $_; next }; + push @names, $_; +} + +#- params contains informations to parse installed system. +my $params = new rpmtools; + +open F, $depslist or die "$depslist file not found, run urpmi.addmedia first\n"; +$params->read_depslist(\*F); +close F; + +if ($query && $query->{group}) { + open F, $compss or die "$compss file not found, run urpmi.addmedia first\n"; + $params->read_compss(\*F); + close F; +} + +if (@files) { + #- read provides file which is needed only to compute incremental + #- dependancies, of files provided. + open F, $provides or die "$provides file not found, run urpmi.addmedia first\n"; + $params->read_provides(\*F); + close F; + + #- compute depslist of files provided on command line. + $params->read_rpms($_) foreach @files; + $params->compute_depslist; + + #- gets full names of packages, sanity check of pathname. + m|(.*/)?(.*)\.[^.]+\.rpm$| and push @names, $2 foreach @files; + m|^/| or $_ = "./$_" foreach @files; +} + +#- reparse whole internal depslist to match against newer packages only. +$params->relocate_depslist(); + +my %exact; +my %found; +my %foundi; +my @packages; + +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 ($params->{info}{$v}) { + $exact{$v} = $params->{info}{$v}; next; + } + + my $qv = quotemeta $v; + foreach (keys %{$params->{info}}) { + my $info = $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; + } +} + +foreach (@names) { + my $info = $exact{$_}; + if ($info) { + push @packages, $info->{id}; + } else { + my $l = $found{$_} || $foundi{$_}; + if (@{$l || []} == 0) { + warn(_("no package named %s\n", $_)); + } elsif (@$l > 1 && !$all) { + warn(_("The following packages contain %s: %s\n", $_, join(' ', map { $_->{name} } @$l))); + } else { + push @packages, map { $_->{id} } @$l; + } + } +} + +#- keep in mind the packages asked by the user, just for interactive activity. +my %packages; @packages{@packages} = (); + +#- compute closure of package to install/upgrade before examining installed +#- packages, this help speed up the process to retrieve installed packages in +#- the given list. +my %packages_to_install; +my @packages_installed; +if (rpmtools::get_packages_installed('', \@packages_installed, [ 'basesystem' ])) { + #- if basesystem is installed and need to be updated. + #- we have to add it in the list explicitely. + #- in order to take care of all basesystem packages. + my $pkg = $params->{info}{basesystem}; + foreach (@packages_installed) { + my $cmp = rpmtools::version_compare($pkg->{version}, $_->{version}); + if ($cmp > 0 || $cmp == 0 && rpmtools::version_compare($pkg->{release}, $_->{release}) > 0) { + push @packages, $pkg->{id}; last; + } + } +} + +my $id; +while (defined($id = shift @packages)) { + if (ref $id) { + #- in such case, this is a dependancy on a choices, check + #- if one of the package is already selected, in such case, the choice + #- can safely be dropped. in other cases, the choices has to be registered. + foreach (@$id) { + exists $packages_to_install{$_} && !$packages_to_install{$_} and $id = undef, last; + } + #- registering the choice is done by adding the class in any referenced id. + if ($id) { + foreach (@$id) { + push @{$packages_to_install{$_} ||= []}, $id; + } + } + } else { + if ($packages_to_install{$id}) { + drop_in_choices(\%packages_to_install, $id); + } + exists $packages_to_install{$id} and next; + #- force selection as mandatory package. + $packages_to_install{$id} = undef; + #- rebuild requires_id array according to deps as requires_id is no more available (because of speed :-) + #- and because id have been relocated. + my @rebuild_requires_id; + foreach (split /\s+/, $params->{depslist}[$id]{deps}) { + if (/\|/) { + push @rebuild_requires_id, [ map { $params->{depslist}[$_]{id} } split /\|/, $_ ]; + } else { + push @rebuild_requires_id, $params->{depslist}[$_]{id}; + } + } + #- get all dependancies to add them. + #- this is a partial closure, it assumes it has already be done before. + foreach (@rebuild_requires_id) { + if (ref $_) { + push @packages, $_; + } else { + $packages_to_install{$_} = undef; + } + } + } +} + +if ($query->{upgrade}) { + #- now the packages_to_install contains as keys all packages that may be selected, + #- this is used to determine a restricted list of packages installed, as it can + #- improve performance on some cases. + my @packages_to_install = map { $params->{depslist}[$_]{name} } keys %packages_to_install; + my @packages_installed; + if (@packages_to_install > 100) { + rpmtools::get_all_packages_installed('', \@packages_installed); + } else { + rpmtools::get_packages_installed('', \@packages_installed, \@packages_to_install); + } + + #- examine installed packages, determine if a package need upgrade or not. + #- this list may be bigger than packages than really need to be upgraded because they + #- are selected. + foreach (@packages_installed) { + my $pkg = $params->{info}{$_->{name}}; + #- if package has not event been selected by upgrade, continue. + #- but if the package is part of a choice, if it need upgrade, the choice will + #- be dropped, if it does not need upgrade, the choice has to been dropped. + #- in any case, a choice has to be dropped. + exists $packages_to_install{$pkg->{id}} or next; + if ($packages_to_install{$pkg->{id}}) { + drop_in_choices(\%packages_to_install, $pkg->{id}); + } + #- at this point, $_ is the package installed and $pkg is the package candidate to install. + my $cmp = rpmtools::version_compare($pkg->{version}, $_->{version}); + if ($cmp < 0 || $cmp == 0 && rpmtools::version_compare($pkg->{release}, $_->{release}) <= 0) { + #- the package $pkg is older or the same as the installed package, + #- this means it has to be removed from the list, and considered to be + #- already installed. + delete $packages_to_install{$pkg->{id}}; + } else { + $packages_to_install{$pkg->{id}} = undef; + } + } +} + +#- query of dependancies will make use of packages_to_install, else just +#- need to use @names where all informations are given, with eventual +#- limitation on packages already installed. +my $l = $query->{deps} ? \%packages_to_install : \%packages; + +#- print sub for query. +my $query_sub = sub { + my ($id) = @_; + my $info = $params->{depslist}[$id]; + my $str = ''; + $query->{group} and $str .= $info->{group} . '/'; + $str .= $info->{name}; + $query->{version} and $str .= '-' . $info->{version}; + $query->{release} and $str .= '-' . $info->{release}; + $str; +}; + +foreach my $id (keys %$l) { + my $class = $l->{$id}; + if ($class) { + my %hack_only_one; + foreach my $choices_id (@{$class || []}) { + exists $hack_only_one{$choices_id} and next; + print join('|', map { $query_sub->($_) } @$choices_id), "\n"; + drop_in_choices($l, $choices_id->[0]); + $hack_only_one{$choices_id} = undef; + } + } else { + exists $l->{$id} and print $query_sub->($id), "\n"; + } +} + +#- remove any reference to package in choices, +#- it is NECESSARY the package to be in a choice, or it will die. +sub drop_in_choices { + my ($packages_to_install, $id) = @_; + + #- the package here is listed in a choices, drop any reference to the choices + #- as this package will have to be selected. + my %class_to_drop; @class_to_drop{@{$packages_to_install->{$id}}} = (); + foreach (keys %$packages_to_install) { + if ($packages_to_install->{$_}) { + my @keeped_choices = grep { ! exists $class_to_drop{$_} } @{$packages_to_install->{$_}}; + if (@keeped_choices) { + $packages_to_install->{$_} = \@keeped_choices; + } else { + delete $packages_to_install->{$_}; + } + } + } +} + +sub _ { + my $s = shift @_; my $t = translate($s); + $t && ref $t or return sprintf $t, @_; + my ($T, @p) = @$t; + sprintf $T, @_[@p]; +} +sub translate { $I18N{$_[0]} || $_[0]; } + +sub load_po { + my ($from, $to, $state, $fuzzy); + + my $lang = $ENV{LANGUAGE} || $ENV{LC_ALL} || $ENV{LC_MESSAGES} || $ENV{LANG}; + my $f; -e ($f = "/usr/share/locale/$_/LC_MESSAGES/urpmi.po") and last foreach split ':', $lang; + + local *F; open F, $f or return; + foreach (<F>) { + /^msgstr/ and $state = 1; + /^msgid/ && !$fuzzy and $state = 2; + + if (/^(#|$)/ && $state != 3) { + $state = 3; + s/\\n/\n/g foreach $from, $to; + + if (my @l = $to =~ /%(\d+)\$/g) { + $to =~ s/%(\d+)\$/%/g; + $to = [ $to, map { $_ - 1 } @l ]; + } + $I18N{$from} = $to if $from; + $from = $to = ''; + } + $to .= (/"(.*)"/)[0] if $state == 1; + $from .= (/"(.*)"/)[0] if $state == 2; + + $fuzzy = /^#, fuzzy/; + } +} |