urpmi/trunk/urpm.pm

package urpm;

# $Id: urpm.pm 271301 2010-11-22 00:50:49Z eugeni $

no warnings 'utf8';
use strict;
use File::Find ();
use urpm::msg;
use urpm::download;
use urpm::util;
use urpm::sys;
use urpm::cfg;
use urpm::md5sum;
# perl_checker: require urpm::args
# perl_checker: require urpm::media
# perl_checker: require urpm::parallel

our $VERSION = '7.8.1';
our @ISA = qw(URPM Exporter);
our @EXPORT_OK = ('file_from_local_url', 'file_from_local_medium', 'is_local_medium');

# Prepare exit code.  If you change this, the exiting with a failure and the message given will be postponed to the end of the overall processing.
our $postponed_msg = N("While some packages may have been installed, there were failures.\n");
our $postponed_code = 0;

use URPM;
use URPM::Resolve;

#- this violently overrides is_arch_compat() to always return true.
sub shunt_ignorearch {
    eval q( sub URPM::Package::is_arch_compat { 1 } );
}

sub xml_info_policies() { qw(never on-demand update-only always) }

sub default_options {
    { 
        'split-level' => 1,
        'split-length' => 8,
        'verify-rpm' => 1,
        'post-clean' => 1,
        'xml-info' => 'on-demand',
        'max-round-robin-tries' => 5,
        'max-round-robin-probes' => 2,
        'days-between-mirrorlist-update' => 5,
        'nb-of-new-unrequested-pkgs-between-auto-select-orphans-check' => 10,
    };
}

#- create a new urpm object.
sub new {
    my ($class) = @_;
    my $self;
    $self = bless {
        # from URPM
        depslist   => [],
        provides   => {},
        obsoletes  => {},

        media      => undef,
        options    => {},

        fatal      => sub { printf STDERR "%s\n", $_[1]; exit($_[0]) },
        error      => sub { printf STDERR "%s\n", $_[0] },
        info       => sub { printf "%s\n", $_[0] }, #- displayed unless --quiet
        log        => sub { printf "%s\n", $_[0] }, #- displayed if --verbose
        print      => sub { printf "%s\n", $_[0] }, #- always displayed, enable to redirect output for eg: installer
    }, $class;

    set_files($self, '');
    $self->set_nofatal(1);
    $self;
}

sub new_parse_cmdline {
    my ($class) = @_;
    my $urpm = $class->new;
    urpm::args::parse_cmdline(urpm => $urpm);
    get_global_options($urpm);
    $urpm;
}

sub _add2hash { my ($a, $b) = @_; while (my ($k, $v) = each %{$b || {}}) { defined $a->{$k} or $a->{$k} = $v } $a }

sub get_global_options {
    my ($urpm) = @_;

    my $config = urpm::cfg::load_config($urpm->{config})
      or $urpm->{fatal}(6, $urpm::cfg::err);

    if (my $global = $config->{global}) {
        _add2hash($urpm->{options}, $global);
    }
    #- remember global options for write_config
    $urpm->{global_config} = $config->{global};

    _add2hash($urpm->{options}, default_options());
}

sub prefer_rooted {
    my ($root, $file) = @_;
    -e "$root$file" ? "$root$file" : $file;
}

sub check_cache_dir {
    my ($urpm, $dir) = @_;
    -d $dir && ! -l $dir or $urpm->{fatal}(1, N("fail to create directory %s", $dir));
    -o $dir && -w $dir or $urpm->{fatal}(1, N("invalid owner for directory %s", $dir));
}

sub init_cache_dir {
    my ($urpm, $dir) = @_;

    mkdir $dir, 0755; # try to create it

    check_cache_dir($urpm, $dir);

    mkdir "$dir/partial";
    mkdir "$dir/rpms";

    $dir;
}
sub userdir_prefix {
    my ($_urpm) = @_;
    '/tmp/.urpmi-';
}
sub userdir {
    #mdkonline uses userdir because it runs as user
    my ($urpm) = @_;
    $< or return;

    my $dir = ($urpm->{urpmi_root} || '') . userdir_prefix($urpm) . $<;
    init_cache_dir($urpm, $dir);
}
sub ensure_valid_cachedir {
    my ($urpm) = @_;
    if (my $dir = userdir($urpm)) {
        $urpm->{cachedir} = $dir;
    }
    -w "$urpm->{cachedir}/partial" or $urpm->{fatal}(1, N("Can not download packages into %s", "$urpm->{cachedir}/partial"));
}
sub valid_cachedir {
    my ($urpm) = @_;
    userdir($urpm) || $urpm->{cachedir};
}

sub is_temporary_file {
    my ($urpm, $f) = @_;

    begins_with($f, $urpm->{cachedir});
}

sub set_env {
    my ($urpm, $env) = @_;
    -d $env or $urpm->{fatal}(8, N("Environment directory %s does not exist", $env));
    print N("using specific environment on %s\n", $env);
    #- setting new environment.
    $urpm->{config} = "$env/urpmi.cfg";
    if (cat_($urpm->{config}) =~ /^\s*virtual\s*$/m) {
        print "dropping virtual from $urpm->{config}\n";
        system(q(perl -pi -e 's/^\s*virtual\s*$//' ) . $urpm->{config});
    }
    $urpm->{mediacfgdir} = "$env/mediacfg.d";
    $urpm->{skiplist} = "$env/skip.list";
    $urpm->{instlist} = "$env/inst.list";
    $urpm->{prefer_list} = "$env/prefer.list";
    $urpm->{prefer_vendor_list} = "$env/prefer.vendor.list";
    $urpm->{statedir} = $env;
    $urpm->{env_rpmdb} = "$env/rpmdb.cz";
    $urpm->{env_dir} = $env;
}

sub set_files {
    my ($urpm, $urpmi_root) = @_;

    $urpmi_root and $urpmi_root = file2absolute_file($urpmi_root);

    my %h = (
        config        => "$urpmi_root/etc/urpmi/urpmi.cfg",
        mediacfgdir   => "$urpmi_root/etc/urpmi/mediacfg.d",
        skiplist      => prefer_rooted($urpmi_root, '/etc/urpmi/skip.list'),
        instlist      => prefer_rooted($urpmi_root, '/etc/urpmi/inst.list'),
        prefer_list   => prefer_rooted($urpmi_root, '/etc/urpmi/prefer.list'),
        prefer_vendor_list => 
                         prefer_rooted($urpmi_root, '/etc/urpmi/prefer.vendor.list'),
        private_netrc => "$urpmi_root/etc/urpmi/netrc",
        statedir      => "$urpmi_root/var/lib/urpmi",
        cachedir      => "$urpmi_root/var/cache/urpmi",
        root          => $urpmi_root,
        $urpmi_root ? (urpmi_root => $urpmi_root) : @{[]},
    );
    $urpm->{$_} = $h{$_} foreach keys %h;

    create_var_lib_rpm($urpm, %h);

   # policy is too use chroot environment only for --urpmi-root, not for --root:
    if ($urpmi_root && -e "$urpmi_root/etc/rpm/macros") {
        URPM::loadmacrosfile("$urpmi_root/etc/rpm/macros");
    }
}

sub create_var_lib_rpm {
    my ($urpm, %h) = @_;
    require File::Path;
    File::Path::mkpath([ $h{statedir}, 
                         (map { "$h{cachedir}/$_" } qw(partial rpms)),
                         dirname($h{config}),
                         "$urpm->{root}/var/lib/rpm",
                         "$urpm->{root}/var/tmp",
                     ]);
}

sub modify_rpm_macro {
    my ($name, $to_remove, $to_add) = @_;

    my $val = URPM::expand('%' . $name);
    $val =~ s/$to_remove/$to_add/ or $val = join(' ', grep { $_ } $val, $to_add);
    URPM::add_macro("$name $val");
}

sub set_tune_rpm {
    my ($urpm, $para) = @_;

    my %h = map { $_ => 1 } map { 
        if ($_ eq 'all') {
            ('nofsync', 'private');
        } else {
            $_;
        }
    } split(',', $para);

    $urpm->{tune_rpm} = \%h;
}

sub tune_rpm {
    my ($urpm) = @_;

    if ($urpm->{tune_rpm}{nofsync}) {
        modify_rpm_macro('__dbi_other', 'fsync', 'nofsync');
    }
    if ($urpm->{tune_rpm}{private}) {
        urpm::sys::clean_rpmdb_shared_regions($urpm->{root});
        modify_rpm_macro('__dbi_other', 'usedbenv', 'private');
    }
}

sub _blist_pkg_to_urls {
    my ($blist, @pkgs) = @_;
    my $base_url = $blist->{medium}{url} . '/';
    map { $base_url . $_->filename } @pkgs;
}
sub blist_pkg_to_url {
    my ($blist, $pkg) = @_;
    my ($url) = _blist_pkg_to_urls($blist, $pkg);
    $url;
}
sub blist_to_urls {
    my ($blist) = @_;
    _blist_pkg_to_urls($blist, values %{$blist->{pkgs}});
}
sub blist_to_filenames {
    my ($blist) = @_;
    map { $_->filename } values %{$blist->{pkgs}};
}

sub protocol_from_url {
    my ($url) = @_;
    $url =~ m!^(\w+)(_[^:]*)?:! && $1;
}
sub file_from_local_url {
    my ($url) = @_;
    $url =~ m!^(?:removable[^:]*:/|file:/)?(/.*)! && $1;
}
sub file_from_local_medium {
    my ($medium, $o_url) = @_;
    my $url = $o_url || $medium->{url};
    if ($url =~ m!^cdrom://(.*)!) {
        my $rel = $1;   
        $medium->{mntpoint} or do { require Carp; Carp::confess("cdrom is not mounted yet!\n") };
        "$medium->{mntpoint}/$rel";
    } else {
        file_from_local_url($url);
    }
}
sub is_local_url {
    my ($url) = @_;
    file_from_local_url($url) || is_cdrom_url($url);
}
sub is_local_medium {
    my ($medium) = @_;
    is_local_url($medium->{url});
}
sub is_cdrom_url {
    my ($url) = @_;
    protocol_from_url($url) eq 'cdrom';
}

sub db_open_or_die_ {
    my ($urpm, $b_write_perm) = @_;
    my $db;
    if ($urpm->{env_rpmdb}) {
        #- URPM has same methods as URPM::DB and empty URPM will be seen as empty URPM::DB.
        $db = URPM->new;
        $db->parse_synthesis($urpm->{env_rpmdb});
    } else {
        $db = db_open_or_die($urpm, $urpm->{root}, $b_write_perm);
    }
    $db;
}

# please use higher level function db_open_or_die_()
sub db_open_or_die {
    my ($urpm, $root, $b_write_perm) = @_;

    $urpm->{debug} and $urpm->{debug}("opening rpmdb (root=$root, write=$b_write_perm)");

    my $db = URPM::DB::open($root, $b_write_perm || 0)
      or $urpm->{fatal}(9, N("unable to open rpmdb"));

    $db;
}

#- register local packages for being installed, keep track of source.
sub register_rpms {
    my ($urpm, @files) = @_;
    my ($start, $id, $error, %requested);

    #- examine each rpm and build the depslist for them using current
    #- depslist and provides environment.
    $start = @{$urpm->{depslist}};
    foreach (@files) {
        /\.(?:rpm|spec)$/ or $error = 1, $urpm->{error}(N("invalid rpm file name [%s]", $_)), next;

        #- if that's an URL, download.
        if (protocol_from_url($_)) {
            my $basename = basename($_);
            unlink "$urpm->{cachedir}/partial/$basename";
            $urpm->{log}(N("retrieving rpm file [%s] ...", $_));
            if (urpm::download::sync_url($urpm, $_, quiet => 1)) {
                $urpm->{log}(N("...retrieving done"));
                $_ = "$urpm->{cachedir}/partial/$basename";
            } else {
                $urpm->{error}(N("...retrieving failed: %s", $@));
                unlink "$urpm->{cachedir}/partial/$basename";
                next;
            }
        } else {
            -r $_ or $error = 1, $urpm->{error}(N("unable to access rpm file [%s]", $_)), next;
        }

        if (/\.spec$/) {
            my $pkg = URPM::spec2srcheader($_)
                or $error = 1, $urpm->{error}(N("unable to parse spec file %s [%s]", $_, $!)), next;
            $id = @{$urpm->{depslist}};
            $urpm->{depslist}[$id] = $pkg;
            $pkg->set_id($id); #- sets internal id to the depslist id.
            $urpm->{source}{$id} = $_;
        } else {
            ($id) = $urpm->parse_rpm($_);
            my $pkg = defined $id && $urpm->{depslist}[$id];
            $pkg or $error = 1, $urpm->{error}(N("unable to register rpm file")), next;
            $pkg->arch eq 'src' || $pkg->is_arch_compat
                or $error = 1, $urpm->{error}(N("Incompatible architecture for rpm [%s]", $_)), next;
            $urpm->{source}{$id} = $_;
        }
    }
    $error and $urpm->{fatal}(2, N("error registering local packages"));
    defined $id && $start <= $id and @requested{($start .. $id)} = (1) x ($id-$start+1);

    #- distribute local packages to distant nodes directly in cache of each machine.
    if (@files && $urpm->{parallel_handler}) {
        $urpm->{parallel_handler}->parallel_register_rpms($urpm, @files);
    }

    %requested;
}

#- checks whether the delta RPM represented by $pkg is installable wrt the
#- RPM DB on $root. For this, it extracts the rpm version to which the
#- delta applies from the delta rpm filename itself. So naming conventions
#- do matter :)
sub is_delta_installable {
    my ($urpm, $pkg, $root) = @_;
    $pkg->flag_installed or return 0;
    my $f = $pkg->filename;
    my $n = $pkg->name;
    my ($v_match) = $f =~ /^\Q$n\E-(.*)_.+\.delta\.rpm$/;
    my $db = db_open_or_die($urpm, $root);
    my $v_installed;
    $db->traverse(sub {
        my ($p) = @_;
        $p->name eq $n and $v_installed = $p->version . '-' . $p->release;
    });
    $v_match eq $v_installed;
}

#- extract package that should be installed instead of upgraded,
#- installing instead of upgrading is useful
#- - for inst.list (cf flag disable_obsolete)
#- sources is a hash of id -> source rpm filename.
sub extract_packages_to_install {
    my ($urpm, $sources) = @_;
    my %inst;

    foreach (keys %$sources) {
        my $pkg = $urpm->{depslist}[$_] or next;
        $pkg->flag_disable_obsolete
          and $inst{$pkg->id} = delete $sources->{$pkg->id};
    }

    \%inst;
}

#- get reason of update for packages to be updated
#- use all update medias if none given
sub get_updates_description {
    my ($urpm, @update_medias) = @_;
    my %update_descr;
    my ($cur, $section);

    @update_medias or @update_medias = urpm::media::non_ignored_media($urpm, 'update');

    foreach my $medium (@update_medias) {
        # fix not taking into account the last %package token of each descrptions file: '%package dummy'
        foreach (cat_utf8(urpm::media::statedir_descriptions($urpm, $medium)),
                 ($::env ? cat_utf8("$::env/descriptions") : ()), '%package dummy') {
            /^%package +(.+)/ and do {
                # fixes not parsing descriptions file when MU adds itself the security source:
                if (exists $cur->{importance} && !member($cur->{importance}, qw(security bugfix))) {
                    $cur->{importance} = 'normal';
                }
                $update_descr{$medium->{name}}{$_} = $cur foreach @{$cur->{pkgs} || []};
                $cur = { pkgs => [ split /\s/, $1 ] };
                $section = 'pkg';
                next;
            };
            /^Updated?: +(.+)/ && $section eq 'pkg' and do { $cur->{updated} = $1; next };
            /^Importance: +(.+)/ && $section eq 'pkg' and do { $cur->{importance} = $1; next };
            /^(ID|URL): +(.+)/ && $section eq 'pkg' and do { $cur->{$1} = $2; next };
            /^%(pre|description)/ and do { $section = $1; next };
            $section  =~ /^(pre|description)\z/ and $cur->{$1} .= $_;
        }
    }
    \%update_descr;
}

sub error_restricted ($) {
    my ($urpm) = @_;
    $urpm->{fatal}(2, N("This operation is forbidden while running in restricted mode"));
}

sub DESTROY {}

1;

__END__

=head1 NAME

urpm - Mageia perl tools to handle the urpmi database

=head1 DESCRIPTION

C<urpm> is used by urpmi executables to manipulate packages and media
on a Mageia Linux distribution.

=head2 The urpm class

=over 4

=item urpm->new()

The constructor creates a new urpm object. It's a blessed hash that
contains fields from L<URPM>, and also the following fields:

B<source>: { id => src_rpm_file|spec_file }

B<media>: [ { 
   start => int, end => int, name => string, url => string,
   virtual => bool, media_info_dir => string, with_synthesis => string,
   no-media-info => bool,
   iso => string, downloader => string,
   ignore => bool, update => bool, modified => bool, really_modified => bool,
   unknown_media_info => bool, 
 } ],

=back

=head1 SEE ALSO

The C<URPM> package is used to manipulate at a lower level synthesis and rpm
files.

=head1 COPYRIGHT

Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 MandrakeSoft SA

Copyright (C) 2005-2010 Mandriva SA

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.

=cut

# ex: set ts=8 sts=4 sw=4 noet:
1	dmorgan	1928	package urpm;
2
3			# $Id: urpm.pm 271301 2010-11-22 00:50:49Z eugeni $
4
5			no warnings 'utf8';
6			use strict;
7			use File::Find ();
8			use urpm::msg;
9			use urpm::download;
10			use urpm::util;
11			use urpm::sys;
12			use urpm::cfg;
13			use urpm::md5sum;
14	tv	2877	# perl_checker: require urpm::args
15			# perl_checker: require urpm::media
16			# perl_checker: require urpm::parallel
17	dmorgan	1928
18	tv	5758	our $VERSION = '7.8.1';
19	dmorgan	1928	our @ISA = qw(URPM Exporter);
20			our @EXPORT_OK = ('file_from_local_url', 'file_from_local_medium', 'is_local_medium');
21
22	tv	3103	# Prepare exit code. If you change this, the exiting with a failure and the message given will be postponed to the end of the overall processing.
23			our $postponed_msg = N("While some packages may have been installed, there were failures.\n");
24			our $postponed_code = 0;
25
26	dmorgan	1928	use URPM;
27			use URPM::Resolve;
28
29			#- this violently overrides is_arch_compat() to always return true.
30			sub shunt_ignorearch {
31			eval q( sub URPM::Package::is_arch_compat { 1 } );
32			}
33
34			sub xml_info_policies() { qw(never on-demand update-only always) }
35
36			sub default_options {
37			{
38			'split-level' => 1,
39			'split-length' => 8,
40			'verify-rpm' => 1,
41			'post-clean' => 1,
42			'xml-info' => 'on-demand',
43			'max-round-robin-tries' => 5,
44			'max-round-robin-probes' => 2,
45			'days-between-mirrorlist-update' => 5,
46			'nb-of-new-unrequested-pkgs-between-auto-select-orphans-check' => 10,
47			};
48			}
49
50			#- create a new urpm object.
51			sub new {
52			my ($class) = @_;
53			my $self;
54			$self = bless {
55			# from URPM
56			depslist => [],
57			provides => {},
58			obsoletes => {},
59
60			media => undef,
61			options => {},
62
63			fatal => sub { printf STDERR "%s\n", $_[1]; exit($_[0]) },
64			error => sub { printf STDERR "%s\n", $_[0] },
65			info => sub { printf "%s\n", $_[0] }, #- displayed unless --quiet
66			log => sub { printf "%s\n", $_[0] }, #- displayed if --verbose
67			print => sub { printf "%s\n", $_[0] }, #- always displayed, enable to redirect output for eg: installer
68			}, $class;
69
70			set_files($self, '');
71			$self->set_nofatal(1);
72			$self;
73			}
74
75			sub new_parse_cmdline {
76			my ($class) = @_;
77			my $urpm = $class->new;
78			urpm::args::parse_cmdline(urpm => $urpm);
79			get_global_options($urpm);
80			$urpm;
81			}
82
83			sub _add2hash { my ($a, $b) = @_; while (my ($k, $v) = each %{$b \|\| {}}) { defined $a->{$k} or $a->{$k} = $v } $a }
84
85			sub get_global_options {
86			my ($urpm) = @_;
87
88			my $config = urpm::cfg::load_config($urpm->{config})
89			or $urpm->{fatal}(6, $urpm::cfg::err);
90
91			if (my $global = $config->{global}) {
92			_add2hash($urpm->{options}, $global);
93			}
94			#- remember global options for write_config
95			$urpm->{global_config} = $config->{global};
96
97			_add2hash($urpm->{options}, default_options());
98			}
99
100			sub prefer_rooted {
101			my ($root, $file) = @_;
102			-e "$root$file" ? "$root$file" : $file;
103			}
104
105	tv	5737	sub check_cache_dir {
106			my ($urpm, $dir) = @_;
107			-d $dir && ! -l $dir or $urpm->{fatal}(1, N("fail to create directory %s", $dir));
108			-o $dir && -w $dir or $urpm->{fatal}(1, N("invalid owner for directory %s", $dir));
109			}
110
111	dmorgan	1928	sub init_cache_dir {
112			my ($urpm, $dir) = @_;
113
114			mkdir $dir, 0755; # try to create it
115
116	tv	5737	check_cache_dir($urpm, $dir);
117	dmorgan	1928
118			mkdir "$dir/partial";
119			mkdir "$dir/rpms";
120
121			$dir;
122			}
123			sub userdir_prefix {
124			my ($_urpm) = @_;
125			'/tmp/.urpmi-';
126			}
127			sub userdir {
128			#mdkonline uses userdir because it runs as user
129			my ($urpm) = @_;
130			$< or return;
131
132			my $dir = ($urpm->{urpmi_root} \|\| '') . userdir_prefix($urpm) . $<;
133			init_cache_dir($urpm, $dir);
134			}
135			sub ensure_valid_cachedir {
136			my ($urpm) = @_;
137			if (my $dir = userdir($urpm)) {
138			$urpm->{cachedir} = $dir;
139			}
140			-w "$urpm->{cachedir}/partial" or $urpm->{fatal}(1, N("Can not download packages into %s", "$urpm->{cachedir}/partial"));
141			}
142			sub valid_cachedir {
143			my ($urpm) = @_;
144			userdir($urpm) \|\| $urpm->{cachedir};
145			}
146
147			sub is_temporary_file {
148			my ($urpm, $f) = @_;
149
150			begins_with($f, $urpm->{cachedir});
151			}
152
153			sub set_env {
154			my ($urpm, $env) = @_;
155			-d $env or $urpm->{fatal}(8, N("Environment directory %s does not exist", $env));
156			print N("using specific environment on %s\n", $env);
157			#- setting new environment.
158			$urpm->{config} = "$env/urpmi.cfg";
159			if (cat_($urpm->{config}) =~ /^\svirtual\s$/m) {
160			print "dropping virtual from $urpm->{config}\n";
161			system(q(perl -pi -e 's/^\svirtual\s$//' ) . $urpm->{config});
162			}
163			$urpm->{mediacfgdir} = "$env/mediacfg.d";
164			$urpm->{skiplist} = "$env/skip.list";
165			$urpm->{instlist} = "$env/inst.list";
166			$urpm->{prefer_list} = "$env/prefer.list";
167			$urpm->{prefer_vendor_list} = "$env/prefer.vendor.list";
168			$urpm->{statedir} = $env;
169			$urpm->{env_rpmdb} = "$env/rpmdb.cz";
170			$urpm->{env_dir} = $env;
171			}
172
173			sub set_files {
174			my ($urpm, $urpmi_root) = @_;
175
176			$urpmi_root and $urpmi_root = file2absolute_file($urpmi_root);
177
178			my %h = (
179			config => "$urpmi_root/etc/urpmi/urpmi.cfg",
180			mediacfgdir => "$urpmi_root/etc/urpmi/mediacfg.d",
181			skiplist => prefer_rooted($urpmi_root, '/etc/urpmi/skip.list'),
182			instlist => prefer_rooted($urpmi_root, '/etc/urpmi/inst.list'),
183			prefer_list => prefer_rooted($urpmi_root, '/etc/urpmi/prefer.list'),
184			prefer_vendor_list =>
185			prefer_rooted($urpmi_root, '/etc/urpmi/prefer.vendor.list'),
186			private_netrc => "$urpmi_root/etc/urpmi/netrc",
187			statedir => "$urpmi_root/var/lib/urpmi",
188			cachedir => "$urpmi_root/var/cache/urpmi",
189			root => $urpmi_root,
190	tv	3856	$urpmi_root ? (urpmi_root => $urpmi_root) : @{[]},
191	dmorgan	1928	);
192			$urpm->{$_} = $h{$_} foreach keys %h;
193
194			create_var_lib_rpm($urpm, %h);
195
196			# policy is too use chroot environment only for --urpmi-root, not for --root:
197			if ($urpmi_root && -e "$urpmi_root/etc/rpm/macros") {
198			URPM::loadmacrosfile("$urpmi_root/etc/rpm/macros");
199			}
200			}
201
202			sub create_var_lib_rpm {
203			my ($urpm, %h) = @_;
204			require File::Path;
205			File::Path::mkpath([ $h{statedir},
206			(map { "$h{cachedir}/$_" } qw(partial rpms)),
207			dirname($h{config}),
208			"$urpm->{root}/var/lib/rpm",
209			"$urpm->{root}/var/tmp",
210			]);
211			}
212
213			sub modify_rpm_macro {
214			my ($name, $to_remove, $to_add) = @_;
215
216			my $val = URPM::expand('%' . $name);
217			$val =~ s/$to_remove/$to_add/ or $val = join(' ', grep { $_ } $val, $to_add);
218			URPM::add_macro("$name $val");
219			}
220
221			sub set_tune_rpm {
222			my ($urpm, $para) = @_;
223
224			my %h = map { $_ => 1 } map {
225			if ($_ eq 'all') {
226			('nofsync', 'private');
227			} else {
228			$_;
229			}
230			} split(',', $para);
231
232			$urpm->{tune_rpm} = \%h;
233			}
234
235			sub tune_rpm {
236			my ($urpm) = @_;
237
238			if ($urpm->{tune_rpm}{nofsync}) {
239			modify_rpm_macro('__dbi_other', 'fsync', 'nofsync');
240			}
241			if ($urpm->{tune_rpm}{private}) {
242			urpm::sys::clean_rpmdb_shared_regions($urpm->{root});
243			modify_rpm_macro('__dbi_other', 'usedbenv', 'private');
244			}
245			}
246
247			sub _blist_pkg_to_urls {
248			my ($blist, @pkgs) = @_;
249			my $base_url = $blist->{medium}{url} . '/';
250			map { $base_url . $_->filename } @pkgs;
251			}
252			sub blist_pkg_to_url {
253			my ($blist, $pkg) = @_;
254			my ($url) = _blist_pkg_to_urls($blist, $pkg);
255			$url;
256			}
257			sub blist_to_urls {
258			my ($blist) = @_;
259			_blist_pkg_to_urls($blist, values %{$blist->{pkgs}});
260			}
261			sub blist_to_filenames {
262			my ($blist) = @_;
263			map { $_->filename } values %{$blist->{pkgs}};
264			}
265
266			sub protocol_from_url {
267			my ($url) = @_;
268			$url =~ m!^(\w+)(_[^:]*)?:! && $1;
269			}
270			sub file_from_local_url {
271			my ($url) = @_;
272			$url =~ m!^(?:removable[^:]:/\|file:/)?(/.)! && $1;
273			}
274			sub file_from_local_medium {
275			my ($medium, $o_url) = @_;
276			my $url = $o_url \|\| $medium->{url};
277			if ($url =~ m!^cdrom://(.*)!) {
278			my $rel = $1;
279			$medium->{mntpoint} or do { require Carp; Carp::confess("cdrom is not mounted yet!\n") };
280			"$medium->{mntpoint}/$rel";
281			} else {
282			file_from_local_url($url);
283			}
284			}
285			sub is_local_url {
286			my ($url) = @_;
287			file_from_local_url($url) \|\| is_cdrom_url($url);
288			}
289			sub is_local_medium {
290			my ($medium) = @_;
291			is_local_url($medium->{url});
292			}
293			sub is_cdrom_url {
294			my ($url) = @_;
295			protocol_from_url($url) eq 'cdrom';
296			}
297
298			sub db_open_or_die_ {
299			my ($urpm, $b_write_perm) = @_;
300			my $db;
301			if ($urpm->{env_rpmdb}) {
302			#- URPM has same methods as URPM::DB and empty URPM will be seen as empty URPM::DB.
303	tv	3547	$db = URPM->new;
304	dmorgan	1928	$db->parse_synthesis($urpm->{env_rpmdb});
305			} else {
306			$db = db_open_or_die($urpm, $urpm->{root}, $b_write_perm);
307			}
308			$db;
309			}
310
311			# please use higher level function db_open_or_die_()
312			sub db_open_or_die {
313			my ($urpm, $root, $b_write_perm) = @_;
314
315			$urpm->{debug} and $urpm->{debug}("opening rpmdb (root=$root, write=$b_write_perm)");
316
317			my $db = URPM::DB::open($root, $b_write_perm \|\| 0)
318			or $urpm->{fatal}(9, N("unable to open rpmdb"));
319
320			$db;
321			}
322
323			#- register local packages for being installed, keep track of source.
324			sub register_rpms {
325			my ($urpm, @files) = @_;
326			my ($start, $id, $error, %requested);
327
328			#- examine each rpm and build the depslist for them using current
329			#- depslist and provides environment.
330			$start = @{$urpm->{depslist}};
331			foreach (@files) {
332			/\.(?:rpm\|spec)$/ or $error = 1, $urpm->{error}(N("invalid rpm file name [%s]", $_)), next;
333
334			#- if that's an URL, download.
335			if (protocol_from_url($_)) {
336			my $basename = basename($_);
337			unlink "$urpm->{cachedir}/partial/$basename";
338			$urpm->{log}(N("retrieving rpm file [%s] ...", $_));
339			if (urpm::download::sync_url($urpm, $_, quiet => 1)) {
340			$urpm->{log}(N("...retrieving done"));
341			$_ = "$urpm->{cachedir}/partial/$basename";
342			} else {
343			$urpm->{error}(N("...retrieving failed: %s", $@));
344			unlink "$urpm->{cachedir}/partial/$basename";
345			next;
346			}
347			} else {
348			-r $_ or $error = 1, $urpm->{error}(N("unable to access rpm file [%s]", $_)), next;
349			}
350
351			if (/\.spec$/) {
352			my $pkg = URPM::spec2srcheader($_)
353			or $error = 1, $urpm->{error}(N("unable to parse spec file %s [%s]", $_, $!)), next;
354			$id = @{$urpm->{depslist}};
355			$urpm->{depslist}[$id] = $pkg;
356			$pkg->set_id($id); #- sets internal id to the depslist id.
357			$urpm->{source}{$id} = $_;
358			} else {
359			($id) = $urpm->parse_rpm($_);
360			my $pkg = defined $id && $urpm->{depslist}[$id];
361			$pkg or $error = 1, $urpm->{error}(N("unable to register rpm file")), next;
362			$pkg->arch eq 'src' \|\| $pkg->is_arch_compat
363			or $error = 1, $urpm->{error}(N("Incompatible architecture for rpm [%s]", $_)), next;
364			$urpm->{source}{$id} = $_;
365			}
366			}
367			$error and $urpm->{fatal}(2, N("error registering local packages"));
368			defined $id && $start <= $id and @requested{($start .. $id)} = (1) x ($id-$start+1);
369
370			#- distribute local packages to distant nodes directly in cache of each machine.
371			if (@files && $urpm->{parallel_handler}) {
372			$urpm->{parallel_handler}->parallel_register_rpms($urpm, @files);
373			}
374
375			%requested;
376			}
377
378			#- checks whether the delta RPM represented by $pkg is installable wrt the
379			#- RPM DB on $root. For this, it extracts the rpm version to which the
380			#- delta applies from the delta rpm filename itself. So naming conventions
381			#- do matter :)
382			sub is_delta_installable {
383			my ($urpm, $pkg, $root) = @_;
384			$pkg->flag_installed or return 0;
385			my $f = $pkg->filename;
386			my $n = $pkg->name;
387			my ($v_match) = $f =~ /^\Q$n\E-(.*)_.+\.delta\.rpm$/;
388			my $db = db_open_or_die($urpm, $root);
389			my $v_installed;
390			$db->traverse(sub {
391			my ($p) = @_;
392			$p->name eq $n and $v_installed = $p->version . '-' . $p->release;
393			});
394			$v_match eq $v_installed;
395			}
396
397			#- extract package that should be installed instead of upgraded,
398			#- installing instead of upgrading is useful
399			#- - for inst.list (cf flag disable_obsolete)
400			#- sources is a hash of id -> source rpm filename.
401			sub extract_packages_to_install {
402	tv	5481	my ($urpm, $sources) = @_;
403	dmorgan	1928	my %inst;
404
405			foreach (keys %$sources) {
406			my $pkg = $urpm->{depslist}[$_] or next;
407			$pkg->flag_disable_obsolete
408			and $inst{$pkg->id} = delete $sources->{$pkg->id};
409			}
410
411			\%inst;
412			}
413
414			#- get reason of update for packages to be updated
415			#- use all update medias if none given
416			sub get_updates_description {
417			my ($urpm, @update_medias) = @_;
418			my %update_descr;
419			my ($cur, $section);
420
421			@update_medias or @update_medias = urpm::media::non_ignored_media($urpm, 'update');
422
423			foreach my $medium (@update_medias) {
424			# fix not taking into account the last %package token of each descrptions file: '%package dummy'
425			foreach (cat_utf8(urpm::media::statedir_descriptions($urpm, $medium)),
426			($::env ? cat_utf8("$::env/descriptions") : ()), '%package dummy') {
427			/^%package +(.+)/ and do {
428			# fixes not parsing descriptions file when MU adds itself the security source:
429			if (exists $cur->{importance} && !member($cur->{importance}, qw(security bugfix))) {
430			$cur->{importance} = 'normal';
431			}
432			$update_descr{$medium->{name}}{$_} = $cur foreach @{$cur->{pkgs} \|\| []};
433			$cur = { pkgs => [ split /\s/, $1 ] };
434			$section = 'pkg';
435			next;
436			};
437			/^Updated?: +(.+)/ && $section eq 'pkg' and do { $cur->{updated} = $1; next };
438			/^Importance: +(.+)/ && $section eq 'pkg' and do { $cur->{importance} = $1; next };
439			/^(ID\|URL): +(.+)/ && $section eq 'pkg' and do { $cur->{$1} = $2; next };
440			/^%(pre\|description)/ and do { $section = $1; next };
441			$section =~ /^(pre\|description)\z/ and $cur->{$1} .= $_;
442			}
443			}
444			\%update_descr;
445			}
446
447			sub error_restricted ($) {
448			my ($urpm) = @_;
449			$urpm->{fatal}(2, N("This operation is forbidden while running in restricted mode"));
450			}
451
452			sub DESTROY {}
453
454			1;
455
456			__END__
457
458			=head1 NAME
459
460			urpm - Mageia perl tools to handle the urpmi database
461
462			=head1 DESCRIPTION
463
464			C<urpm> is used by urpmi executables to manipulate packages and media
465			on a Mageia Linux distribution.
466
467			=head2 The urpm class
468
469			=over 4
470
471			=item urpm->new()
472
473			The constructor creates a new urpm object. It's a blessed hash that
474	tv	5918	contains fields from L<URPM>, and also the following fields:
475	dmorgan	1928
476			B<source>: { id => src_rpm_file\|spec_file }
477
478			B<media>: [ {
479			start => int, end => int, name => string, url => string,
480			virtual => bool, media_info_dir => string, with_synthesis => string,
481			no-media-info => bool,
482			iso => string, downloader => string,
483			ignore => bool, update => bool, modified => bool, really_modified => bool,
484			unknown_media_info => bool,
485			} ],
486
487			=back
488
489			=head1 SEE ALSO
490
491			The C<URPM> package is used to manipulate at a lower level synthesis and rpm
492			files.
493
494			=head1 COPYRIGHT
495
496			Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 MandrakeSoft SA
497
498			Copyright (C) 2005-2010 Mandriva SA
499
500			This program is free software; you can redistribute it and/or modify
501			it under the terms of the GNU General Public License as published by
502			the Free Software Foundation; either version 2, or (at your option)
503			any later version.
504
505			This program is distributed in the hope that it will be useful,
506			but WITHOUT ANY WARRANTY; without even the implied warranty of
507			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
508			GNU General Public License for more details.
509
510			You should have received a copy of the GNU General Public License
511			along with this program; if not, write to the Free Software
512			Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
513
514			=cut
515
516			# ex: set ts=8 sts=4 sw=4 noet: