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 qw(subs vars refs);
use urpm;
# for i18n
use POSIX;
use Locale::GetText;

setlocale (LC_ALL, "");
Locale::GetText::textdomain ("urpmi");

import Locale::GetText I_;
*_ = *I_;

#- default options.
my $query = {};

my @files;
my @names;

#my %I18N;
#load_po();

sub usage {
    #die(_("usage: urpmq [-h] [-d] [-u] [-c] [-g] [-v] [-r] package_name|rpm_file [package_names|rpm_files...]\n"));
    die( sprintf( _("urpmq version %s
Copyright (C) 2000 MandrakeSoft.
This is free software and may be redistributed under the terms of the GNU GPL.

usage:
  -h             - print this help message.
  -d             - extend query to package dependancies.
  -u             - remove package if a better version is already installed.
  -c             - choose complete method for resolving requires closure.
  -g             - print groups too with name.
  -v             - print version too with name.
  -r             - print release too with name.

  --auto-select  - automatically select packages for upgrading the system.
  --headers      - extract headers for package listed from urpmi db to
                   stdout (root only).

  names or rpm files given on command line are queried.
", $urpm::VERSION)));
}

#- parse arguments list.
my @nextargv;
for (@ARGV) {
    /^--help$/ and do { usage; next };
    /^--auto-select$/ and do { $query->{auto_select} = 1; next };
    /^--headers$/ and do { $query->{headers} = 1; 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 };
	/c/ and do { $query->{complete} = 1; next };
	/g/ and do { $query->{group} = 1; next };
	/v/ and do { $query->{version} = 1; next };
	/r/ and do { $query->{release} = 1; next };
	die( sprintf _("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 $urpm = new urpm;

$urpm->read_depslist;
$query && $query->{group} and $urpm->read_compss;

if (@files) {
    #- read provides file which is needed only to compute incremental
    #- dependancies, of files provided.
    $urpm->read_provides;

    #- compute depslist of files provided on command line.
    $urpm->{params}->read_rpms($_) foreach @files;
    $urpm->{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.
$urpm->{params}->relocate_depslist();

#- 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 dependancy
#- will be updated too.
my %packages;
$urpm->search_packages(\%packages, [ @names ]) or exit 1;

#- auto select package for upgrading the distribution.
if ($query->{auto_select}) {
    my (%to_remove, %keep_files);

    $urpm->select_packages_to_upgrade('', \%packages, \%to_remove, \%keep_files);

    if (keys(%to_remove) > 0) {
	print STDERR _("some package have to be removed for being upgraded, this is not supported yet\n");
    }
}

#- filter to add in packages selected required packages.
$query->{deps} && !$query->{upgrade} and $urpm->compute_closure(\%packages);
$query->{upgrade} and $urpm->filter_packages_to_upgrade(\%packages, complete => $query->{complete});

if ($query->{headers}) {
    $urpm->read_config();

    my ($local_sources, $list) = $urpm->get_source_packages(\%packages);
    unless ($local_sources || $list) {
	die( sprintf _("unable to get source packages, aborting"));
	exit 1;
    }

    #- now examine source package to build headers list to extract.
    foreach (@$local_sources) {
	system 'rpm2header', @$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" } @{$list->[$_]});
	@headers > 0 or next;

	require packdrake;
	my $packer = new packdrake("$urpm->{statedir}/$urpm->{media}[$_]{hdlist}");
	$packer->extract_archive(undef, @headers);
    }
    exit 0;
}

#- print sub for query.
my $query_sub = sub {
	my ($id) = @_;
	my $info = $urpm->{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;
};

my %hack_only_one;
foreach my $id (keys %packages) {
    my $class = $packages{$id};
    if (ref $class) {
	foreach my $choices (@{$class || []}) {
	    exists $hack_only_one{$choices} and next;
	    print join('|', map { $query_sub->($_) } @$choices), "\n";
	    $hack_only_one{$choices} = undef;
	}
    } else {
	exists $packages{$id} and print $query_sub->($id), "\n";
    }
}

#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/;
    }
}