perl-install/install2


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38

#!/usr/bin/perl
#- PERL_INSTALL_TEST is used to launch stage2 in debug mode

#- Mandrake Graphic Install $Id$
#- Copyright (C) 1999/2000 Mandrakesoft (pixel@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.

use diagnostics;
use strict;

BEGIN {
    #- for testing purpose
    (my $f = __FILE__) =~ s|install2$|list_modules.pm|;
    -e $f or symlink '../kernel/list_modules.pm', $f;
}

use lib qw(/usr/lib/libDrakX .);
use install2;

$::testing = $ENV{PERL_INSTALL_TEST};
$::isStandalone = 0;

install2::main(@ARGV);

c::_exit(0);
package URPM;

use strict;
use warnings;
use DynaLoader;

# different files, but same package
# require them here to avoid dependencies
use URPM::Build;
use URPM::Resolve;
use URPM::Signature;

our @ISA = qw(DynaLoader);
our $VERSION = '4.29';

URPM->bootstrap($VERSION);

sub new {
    my ($class, %options) = @_;
    my $self = bless {
	depslist => [],
	provides => {},
	obsoletes => {},
    }, $class;
    $self->{nofatal} = 1 if $options{nofatal};
    $self;
}

sub set_nofatal {
    my ($urpm, $bool) = @_;
    $urpm->{nofatal} = $bool }

sub packages_providing {
    my ($urpm, $name) = @_;
    grep { $_ } map { $urpm->{depslist}[$_] } sort { $a <=> $b } keys %{$urpm->{provides}{$name} || {}};
}

sub packages_obsoleting {
    my ($urpm, $name) = @_;
    map { $urpm->{depslist}[$_] } keys %{$urpm->{obsoletes}{$name} || {}};
}

sub packages_by_name {
    my ($urpm, $name) = @_;
    grep { $name eq $_->name } packages_providing($urpm, $name);
}

sub search {
    my ($urpm, $name, %options) = @_;
    my $best;

    #- tries other alternative if no strict searching.
    unless ($options{strict_name}) {
	if ($name =~ /^(.*)-([^\-]*)-([^\-]*)\.([^\.\-]*)$/) {
	    foreach my $pkg (packages_providing($urpm, $1)) {
		$pkg->fullname eq $name and return $pkg;
	    }
	}
	unless ($options{strict_fullname}) {
	    if ($name =~ /^(.*)-([^\-]*)-([^\-]*)$/) {
		foreach my $pkg (packages_providing($urpm, $1)) {
		    my ($n, $v, $r, $a) = $pkg->fullname;
		    $options{src} && $a eq 'src' || $pkg->is_arch_compat or next;
		    "$n-$v-$r" eq $name or next;
		    !$best || $pkg->compare_pkg($best) > 0 and $best = $pkg;
		}
		$best and return $best;
	    }
	    if ($name =~ /^(.*)-([^\-]*)$/) {
		foreach my $pkg (packages_providing($urpm, $1)) {
		    my ($n, $v, undef, $a) = $pkg->fullname;
		    $options{src} && $a eq 'src' || $pkg->is_arch_compat or next;
		    "$n-$v" eq $name or next;
		    !$best || $pkg->compare_pkg($best) > 0 and $best = $pkg;
		}
		$best and return $best;
	    }
	}
    }

    unless ($options{strict_fullname}) {
	foreach my $pkg (packages_providing($urpm, $name)) {
	    my ($n, undef, undef, $a) = $pkg->fullname;
	    $options{src} && $a eq 'src' || $pkg->is_arch_compat or next;
	    $n eq $name or next;
	    !$best || $pkg->compare_pkg($best) > 0 and $best = $pkg;
	}
    }

    return $best;
}

#- Olivier Thauvin:
#- Returns @$listid, $start .. $end or the whole deplist id
#- according to the given args
sub build_listid {
    my ($urpm, $start, $end, $listid) = @_;

    @{$listid || []} > 0 ? @$listid :