path: root/urpmq

#!/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 <proxyhost[:port]>).
") . _("  --proxy-user   - specify user and password to use for proxy
                   authentication (format is <user:password>).
") . _("  -v             - verbose mode.
") . _("  -d             - extend query to package dependencies.
") . _("  -u             - remove package if a more recent version is already installed.
") . _("  -c             - complete output with package to removes.
") . _("  -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;
@ARGV or usage;
while (defined($_ = shift @ARGV)) {
    /^--help$/ and do { usage };
    /^--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 (<PARALLEL>) {
	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;
if ($query->{complete}) {
    foreach my $removal (keys %{$state->{ask_remove} || {}}) {
	print '@removing@' . $removal . "\n";
    }
}
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";
    }
}