#!/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; use urpm; # get I18N translation method. import urpm _; #- default options. my $query = { use_provides => 1, }; my @files; my @names; my @src_names; sub usage { print STDERR _("urpmq version %s Copyright (C) 2000, 2001, 2002 MandrakeSoft. This is free software and may be redistributed under the terms of the GNU GPL. usage: ", $urpm::VERSION) . _(" --help - print this help message. ") . _(" --update - use only update media. ") . _(" --media - use only the media listed by comma. ") . _(" --synthesis - use the synthesis given instead of urpmi db. ") . _(" --auto-select - automatically select packages to upgrade the system. ") . _(" --fuzzy - impose fuzzy search (same as -y). ") . _(" --list - list available packages. ") . _(" --list-media - list available media. ") . _(" --list-nodes - list available nodes when using --parallel. ") . _(" --list-aliases - list available parallel aliases. ") . _(" --src - next package is a source package (same as -s). ") . _(" --headers - extract headers for package listed from urpmi db to stdout (root only). ") . _(" --sources - give all source packages before downloading (root only). ") . _(" --force - force invocation even if some packages do not exist. ") . _(" --parallel - distributed urpmi accross machines of alias. ") . _(" --wget - use wget to retrieve distant files. ") . _(" --curl - use curl to retrieve distant files. ") . _(" --proxy - use specified HTTP proxy, the port number is assumed to be 1080 by default (format is ). ") . _(" --proxy-user - specify user and password to use for proxy authentication (format is ). ") . _(" -v - verbose mode. ") . _(" -d - extend query to package dependencies. ") . _(" -u - remove package if a more recent version is already installed. ") . _(" -c - choose complete method for resolving requires closure. ") . _(" -P - do not search in provides to find package. ") . _(" -R - reverse search to what requires package. ") . _(" -y - impose fuzzy search (same as --fuzzy). ") . _(" -s - next package is a source package (same as --src). ") . _(" -g - print groups with name also. ") . _(" -r - print version and release with name also. ") . _(" -f - print version, release and arch with name. ") . "\n" . _(" names or rpm files given on command line are queried. "); exit(0); } #- params contains informations to parse installed system. my $urpm = new urpm; #- parse arguments list. my @nextargv; for (@ARGV) { /^--help$/ and do { usage; next }; /^--update$/ and do { $query->{update} = 1; next }; /^--media$/ and do { push @nextargv, \$query->{media}; next }; /^--mediums$/ and do { push @nextargv, \$query->{media}; next }; /^--synthesis$/ and do { push @nextargv, \$query->{synthesis}; next }; /^--auto-select$/ and do { $query->{deps} = $query->{upgrade} = $query->{auto_select} = 1; next }; /^--fuzzy$/ and do { $query->{fuzzy} = 1; next }; /^--list$/ and do { $query->{list} = 1; next }; /^--list-media$/ and do { $query->{list_media} = 1; next }; /^--list-nodes$/ and do { $query->{list_nodes} = 1; next }; /^--list-aliases$/ and do { $query->{list_aliases} = 1; next }; /^--src$/ and do { $query->{src} = 1; next }; /^--headers$/ and do { $query->{headers} = 1; next }; /^--sources$/ and do { $query->{sources} = 1; next }; /^--force$/ and do { $query->{force} = 1; next }; /^--root$/ and do { push @nextargv, \$query->{root}; next }; /^--parallel$/ and do { push @nextargv, \$query->{parallel}; next }; /^--wget$/ and do { $urpm->{sync} = sub { my $options = shift @_; if (ref $options) { $options->{prefer} = 'wget' } else { $options = { dir => $options, prefer => 'wget' } } urpm::sync_webfetch($options, @_) }; next }; /^--curl$/ and do { $urpm->{sync} = \&urpm::sync_webfetch; next }; /^--proxy$/ and do { my ($proxy, $port) = ($_ = shift @ARGV) =~ m,^(?:http://)?([^:]+(:\d+)?)/*$, or die _("bad proxy declaration on command line\n"); $proxy .= ":1080" unless $port; $urpm->{proxy}{http_proxy} = "http://$proxy"; next; }; /^--proxy-user$/ and do { ($_ = shift @ARGV) =~ /(.+):(.+)/, or die _("bad proxy declaration on command line\n"); $urpm->{proxy}{user} = $1; $urpm->{proxy}{pwd} = $2; 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 }; /m/ and do { $query->{deps} = $query->{upgrade} = 1; next }; /M/ and do { $query->{deps} = $query->{upgrade} = 1; next }; /c/ and do { $query->{complete} = 1; next }; /g/ and do { $query->{group} = 1; next }; /p/ and do { $query->{use_provides} = 1; next }; /P/ and do { $query->{use_provides} = 0; next }; /R/ and do { $query->{what_requires} = 1; next }; /y/ and do { $query->{fuzzy} = 1; next }; /s/ and do { $query->{src} = 1; next }; /v/ and do { $query->{verbose} = 1; next }; /r/ and do { $query->{version} = $query->{release} = 1; next }; /f/ and do { $query->{version} = $query->{release} = $query->{arch} = 1; next }; print STDERR _("urpmq: unknown option \"-%s\", check usage with --help\n", $1); exit(1) } next }; @nextargv and do { my $r = shift @nextargv; $r and $$r = $_; next }; /\.rpm$/ and do { if (-r $_) { push @files, $_; } else { print STDERR _("urpmq: cannot read rpm file \"%s\"\n", $_); } next }; if ($query->{src}) { push @src_names, $_; } else { push @names, $_; } $query->{src} = 0; #- reset switch for next package. } #- remove verbose if not asked. $query->{verbose} or $urpm->{log} = sub {}; $urpm->configure(nocheck_access => 1, media => $query->{media}, synthesis => $query->{synthesis}, update => $query->{update}, root => $query->{root}, parallel => $query->{parallel}, ); my $state = {}; my %requested; if ($query->{list_aliases}) { local ($_, *PARALLEL); open PARALLEL, "/etc/urpmi/parallel.cfg"; while () { chomp; s/#.*$//; s/^\s*//; s/\s*$//; /\s*([^:]*):/ or next; print "$1\n"; } close PARALLEL; } elsif ($query->{list_nodes}) { $query->{parallel} or $urpm->{fatal}(1, _("--list-nodes can only be used with --parallel")); foreach (keys %{$urpm->{parallel_handler}{nodes} || {}}) { print "$_\n"; } exit 0; } elsif ($query->{list_media}) { foreach (@{$urpm->{media}}) { print "$_->{name}\n"; } exit 0; } elsif ($query->{list}) { #- if list has been activated, select all... @{$state->{selected}}{0 .. $#{$urpm->{depslist}}} = (); } else { %requested = $urpm->register_rpms(@files); #- search the packages according the selection given by the user, #- basesystem is added to the list so if it need to be upgraded, all its dependency #- will be updated too. if (@names) { $urpm->search_packages(\%requested, [ @names ], use_provides => $query->{use_provides}, fuzzy => $query->{fuzzy}) or $query->{force} or exit 1; } if (@src_names) { $urpm->search_packages(\%requested, [ @src_names ], use_provides => $query->{use_provides}, fuzzy => $query->{fuzzy}, src => 1) or $query->{force} or exit 1; } #- keep track of choices, do no propagate but mark them in selected. my $stop_on_choices = sub { my ($urpm, $db, $state, $choices) = @_; $state->{selected}{join '|', sort { $a <=> $b } map { $_ ? ($_->id) : () } @$choices} = 0; }; #- open/close of database should be moved here, in order to allow testing #- some bogus case and check for integrity. (note auto_select implies upgrade). if ($query->{what_requires}) { #- search for packages that requires on of the package proposed. my (@properties, %requires, %properties, $dep); #- keep in mind the requested id (if given) in order to prefer these packages #- on choices instead of anything other one. @properties = keys %requested; if (@properties) { require URPM::Resolve; #- build a requires to packages id hash. foreach my $pkg (@{$urpm->{depslist}}) { foreach ($pkg->requires_nosense) { $requires{$_}{$pkg->id} = undef; } } #- for each dep property evaluated, examine which package will be obsoleted on $db, #- then examine provides that will be removed (which need to be satisfied by another #- package present or by a new package to upgrade), then requires not satisfied and #- finally conflicts that will force a new upgrade or a remove. while (defined ($dep = shift @properties)) { #- take the best package for each choices of same name. my $packages = $urpm->find_candidate_packages($dep); foreach (values %$packages) { my ($best_requested, $best); foreach (@$_) { if ($best_requested || exists $requested{$_->id}) { if ($best_requested && $best_requested != $_) { $_->compare_pkg($best_requested) > 0 and $best_requested = $_; } else { $best_requested = $_; } } elsif ($best && $best != $_) { $_->compare_pkg($best) > 0 and $best = $_; } else { $best = $_; } } #- examine all choice proposed. my $pkg = $best_requested || $best or next; exists $state->{selected}{$pkg->id} and next; $state->{selected}{$pkg->id} = undef; #- for all provides of package, look of what is requiring them. foreach ($pkg->provides) { if (my ($n, $s) = /^([^\s\[]*)(?:\[\*\])?\[?([^\s\]]*\s*[^\s\]]*)/) { foreach (map { $urpm->{depslist}[$_] } grep { ! exists $state->{selected}{$_} && ! exists $properties{$_} } keys %{$requires{$n} || {}}) { if (grep { URPM::ranges_overlap("$n $s", $_) } $_->requires) { push @properties, $_->id; $properties{$_->id} = undef; } } } } } } } } elsif ($query->{auto_select} || $query->{upgrade}) { $urpm->resolve_dependencies($state, \%requested, auto_select => $query->{auto_select}, callback_choices => $stop_on_choices); $query->{deps} or delete @{$state->{selected}}{grep { exists $state->{selected}{$_} && ! defined $state->{selected}{$_}} keys %{$state->{selected}}}; } elsif ($query->{deps}) { #- only deps required. my $empty_db = new URPM; #- URPM has same methods as URPM::DB and empty URPM will be seen as empty URPM::DB. require URPM::Resolve; $urpm->resolve_requested($empty_db, $state, \%requested, callback_choices => $stop_on_choices); } else { $state->{selected} = \%requested; } #- get out of package that should not be upgraded. $urpm->deselect_unwanted_packages($state->{selected}); if ($query->{headers} || $query->{sources}) { my ($local_sources, $list) = $urpm->get_source_packages($state->{selected}); unless ($local_sources || $list) { $urpm->{fatal}(1, _("unable to get source packages, aborting")); } if ($query->{headers}) { #- now examine source package to build headers list to extract. values %$local_sources and system 'rpm2header', values %$local_sources; foreach (0..$#{$urpm->{media} || []}) { my @headers = (grep { my $file = "$urpm->{cachedir}/headers/$_"; -s $file and system 'cat', $file; ! -s $file } map { /(.*)\/([^\/]*)-([^-]*)-([^-]*)\.([^\.]*)\.rpm/ and "$2-$3-$4.$5" } values %{$list->[$_]}); @headers > 0 or next; if (-s "$urpm->{statedir}/$urpm->{media}[$_]{hdlist}") { require packdrake; my $packer = new packdrake("$urpm->{statedir}/$urpm->{media}[$_]{hdlist}"); $packer->extract_archive(undef, @headers); } else { #- fallback to retrieve rpm package before, so that --headers will be ok. my %downloads = $urpm->download_source_packages({}, $list, 'local', undef); print STDERR join " ", "rpm2header", values %downloads; system "rpm2header", values %downloads; } } } else { print join "\n", values %$local_sources; values %$local_sources and print "\n"; foreach (0..$#{$urpm->{media} || []}) { print join "\n", values %{$list->[$_]}; values %{$list->[$_]} and print "\n"; } } exit 0; } } #- print sub for query. my $query_sub = sub { my ($id) = @_; my $pkg = $urpm->{depslist}[$id]; my $str = ''; $query->{group} and $str .= $pkg->group . '/'; $str .= $pkg->name; $query->{version} and $str .= '-' . $pkg->version; $query->{release} and $str .= '-' . $pkg->release; $query->{arch} and $str .= '.' . $pkg->arch; $str; }; my %hack_only_one; foreach my $id ($state->{selected} ? keys %{$state->{selected}} : keys %requested) { my $class = $state->{selected}{$id} || $requested{$id}; if (ref $class eq 'ARRAY') { foreach my $choices (@{$class || []}) { exists $hack_only_one{$choices} and next; print join('|', map { $query_sub->($_) } @$choices), "\n"; $hack_only_one{$choices} = undef; } } else { print join('|', map { $query_sub->($_) } split '\|', $id), "\n"; } }