File Coverage

blib/lib/urpm.pm
Criterion Covered Total %
statement 10 12 83.3
branch n/a
condition n/a
subroutine 4 4 100.0
pod n/a
total 14 16 87.5


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