summaryrefslogtreecommitdiffstats
path: root/urpm/main_loop.pm
blob: 66b211b36adfc80af4cbcd13e470c42b6d95ce86 (plain)
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
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
package urpm::main_loop;

# $Id: main_loop.pm 271299 2010-11-21 15:54:30Z peroyvind $

#- Copyright (C) 1999, 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.

use strict;
use urpm;
use urpm::args;
use urpm::msg;
use urpm::install;
use urpm::media;
use urpm::select;
use urpm::orphans;
use urpm::get_pkgs;
use urpm::signature;
use urpm::util qw(difference2 find intersection member partition untaint);

#- global boolean options
my ($auto_select, $no_install, $install_src, $clean, $noclean, $force, $parallel, $test);
#- global counters
my ($ok, $nok);
my $exit_code;


=head1 NAME

urpm::main_loop - The install/remove main loop for urpm based programs (urpmi, gurpmi, rpmdrake, drakx)

=head1 SYNOPSIS

=head1 DESCRIPTION

=over

=cut

sub _download_callback {
    my ($urpm, $callbacks, $raw_msg, $msg) = @_;
    if (my $download_errors = delete $urpm->{download_errors}) {
        $raw_msg = join("\n", @$download_errors, '');
    }
    $callbacks->{ask_yes_or_no}('', $raw_msg . "\n" . $msg . "\n" . N("Retry?"));
}

sub _download_packages {
    my ($urpm, $callbacks, $blists, $sources) = @_;
    my @error_sources;
    urpm::get_pkgs::download_packages_of_distant_media(
        $urpm,
        $blists,
        $sources,
        \@error_sources,
        quiet => $options{verbose} < 0,
        callback => $callbacks->{trans_log},
        ask_retry => !$urpm->{options}{auto} && ($callbacks->{ask_retry} || sub {
                                                     _download_callback($urpm, $callbacks, @_);
                                                 }),
    );
    my @msgs;
    if (@error_sources) {
        $_->[0] = urpm::download::hide_password($_->[0]) foreach @error_sources;
        my @bad = grep { $_->[1] eq 'bad' } @error_sources;
        my @missing = grep { $_->[1] eq 'missing' } @error_sources;

        if (@missing) {
            push @msgs, N("Installation failed, some files are missing:\n%s", 
                          join("\n", map { "    $_->[0]" } @missing))
              . "\n" .
                N("You may need to update your urpmi database.");
            $urpm->{nb_install} -= scalar @missing;
        }
        if (@bad) {
            push @msgs, N("Installation failed, bad rpms:\n%s",
                          join("\n", map { "    $_->[0]" } @bad));
        }
    }
    
    (\@error_sources, \@msgs);
}

sub _download_all {
    my ($urpm, $blists, $sources, $callbacks) = @_;
    if ($urpm->{options}{'download-all'}) {
        $urpm->{cachedir} = $urpm->{'urpmi-root'} . $urpm->{options}{'download-all'};
        urpm::init_dir($urpm, $urpm->{cachedir});
    }
    my (undef, $available) = urpm::sys::df("$urpm->{cachedir}/rpms");

    if (!$urpm->{options}{ignoresize}) {
        my ($download_size) = urpm::get_pkgs::get_distant_media_filesize($blists, $sources); 
        if ($download_size >= $available*1000) {
            my $p = N("There is not enough space on your filesystem to download all packages (%s needed, %s available).\nAre you sure you want to continue?", formatXiB($download_size), formatXiB($available*1000)); 
            $force || urpm::msg::ask_yes_or_no($p) or return 10;
        }	
    }

    #download packages one by one so that we don't try to download them again
    #and again if the user has to restart urpmi because of some failure
    my %downloaded_pkgs;
    foreach my $blist (@$blists) {
        foreach my $pkg (keys %{$blist->{pkgs}}) {
            next if $downloaded_pkgs{$pkg};
            my $blist_one = [{ pkgs => { $pkg => $blist->{pkgs}{$pkg} }, medium => $blist->{medium} }];
            my ($error_sources) = _download_packages($urpm, $callbacks, $blist_one, $sources);
            if (@$error_sources) {
                return 10;
            }
            $downloaded_pkgs{$pkg} = 1;
        }
    }
}

sub _verify_rpm {
    my ($urpm, $callbacks, $transaction_sources_install, $transaction_sources) = @_;
    $callbacks->{pre_check_sig} and $callbacks->{pre_check_sig}->();
    my @bad_signatures = urpm::signature::check($urpm, $transaction_sources_install, $transaction_sources,
                                                callback => $callbacks->{check_sig}, basename => $options{basename}
                                            );

    if (@bad_signatures) {
        my $msg = @bad_signatures == 1 ?
          N("The following package has bad signature")
            : N("The following packages have bad signatures");
        my $msg2 = N("Do you want to continue installation ?");
        my $p = join "\n", @bad_signatures;
        my $res = $callbacks->{bad_signature}->("$msg:\n$p\n", $msg2);
        return $res ? 0 : 16;
    }
}

sub _install_src {
    my ($urpm, $transaction_sources_install, $transaction_sources) = @_;
    if (my @l = grep { /\.src\.rpm$/ } values %$transaction_sources_install, values %$transaction_sources) {
        my $rpm_opt = $options{verbose} >= 0 ? 'vh' : '';
        push @l, "--root", $urpm->{root} if $urpm->{root};
        system("rpm", "-i$rpm_opt", @l);
        #- Warning : the following message is parsed in urpm::parallel_*
        if ($?) {
            $urpm->{print}(N("Installation failed"));
            ++$nok;
        } elsif ($urpm->{options}{'post-clean'}) {
            if (my @tmp_srpm = grep { urpm::is_temporary_file($urpm, $_) } @l) {
                $urpm->{log}(N("removing installed rpms (%s)", join(' ', @tmp_srpm)));
                unlink @tmp_srpm;
            }
        }
    }
}

sub clean_trans_sources_from_src_packages {
    my ($urpm, $transaction_sources_install, $transaction_sources) = @_;
    foreach ($transaction_sources_install, $transaction_sources) {
        foreach my $id (keys %$_) {
            my $pkg = $urpm->{depslist}[$id] or next;
            $pkg->arch eq 'src' and delete $_->{$id};
        }
    }
}

sub _continue_on_error {
    my ($urpm, $callbacks, $msgs, $error_sources, $formatted_errors) = @_;
    my $go_on;
    if ($urpm->{options}{auto}) {
        push @$formatted_errors, @$msgs;
    } else {
        my $sub = $callbacks->{ask_for_bad_or_missing} || $callbacks->{ask_yes_or_no};
        $go_on = $sub->(
            N("Installation failed"),
            join("\n\n", @$msgs, N("Try to continue anyway?")));
    }
    if (!$go_on) {
        my @missing = grep { $_->[1] eq 'missing' } @$error_sources;
        if (@missing) {
            $exit_code = $ok ? 13 : 14;
        }
        return 0;
    }
    return 1;
}

sub _handle_removable_media {
    my ($urpm, $callbacks, $blists, $sources) = @_;
    urpm::removable::try_mounting_non_cdroms($urpm, $blists);

    $callbacks->{pre_removable} and $callbacks->{pre_removable}->();
    require urpm::cdrom;
    urpm::cdrom::copy_packages_of_removable_media($urpm,
                                                  $blists, $sources,
                                                  $callbacks->{copy_removable});
    $callbacks->{post_removable} and $callbacks->{post_removable}->();
}

sub _init_common_options {
  my ($urpm, $state, $callbacks) = @_;
  (
      urpm::install::options($urpm),
      test => $test,
      verbose => $options{verbose},
      script_fd => $urpm->{options}{script_fd},
      oldpackage => $state->{oldpackage},
      justdb => $options{justdb},
      replacepkgs => $options{replacepkgs},
      callback_close_helper => $callbacks->{close_helper},
      callback_inst => $callbacks->{inst},
      callback_open_helper => $callbacks->{open_helper},
      callback_trans => $callbacks->{trans},
      callback_report_uninst => $callbacks->{callback_report_uninst},
      raw_message => 1,
  );
}

sub _log_installing {
    my ($urpm, $transaction_sources_install, $transaction_sources) = @_;
    if (my @packnames = (values $transaction_sources_install, values $transaction_sources)) {
        (my $common_prefix) = $packnames[0] =~ m!^(.*)/!;
        if (length($common_prefix) && @packnames == grep { m!^\Q$common_prefix/! } @packnames) {
            #- there's a common prefix, simplify message
            $urpm->{print}(N("installing %s from %s", join(' ', map { s!.*/!!; $_ } @packnames), $common_prefix));
        } else {
            $urpm->{print}(N("installing %s", join "\n", @packnames));
        }
    }
}

sub _run_parallel_transaction {
    my ($urpm, $state, $transaction_sources, $transaction_sources_install) = @_;
    $urpm->{print}(N("distributing %s", join(' ', values $transaction_sources_install, values $transaction_sources)));
    #- no remove are handle here, automatically done by each distant node.
    $urpm->{log}("starting distributed install");
    $urpm->{parallel_handler}->parallel_install(
        $urpm,
        [ keys %{$state->{rejected} || {}} ], $transaction_sources_install, $transaction_sources,
        test => $test,
        excludepath => $urpm->{options}{excludepath}, excludedocs => $urpm->{options}{excludedocs},
    );
}

sub _run_transaction {
    my ($urpm, $state, $callbacks, $set, $transaction_sources_install, $transaction_sources, $errors) = @_;

    my $options = $urpm->{options};
    my $allow_force = $options->{'allow-force'};

    my $to_remove = $allow_force ? [] : $set->{remove} || [];

    $urpm->{log}("starting installing packages");
	    
    urpm::orphans::add_unrequested($urpm, $state) if !$test;

    my %install_options_common = _init_common_options($urpm, $state, $callbacks);

  install:
    my @l = urpm::install::install($urpm,
                                   $to_remove,
                                   $transaction_sources_install, $transaction_sources,
                                   %install_options_common,
                               );

    if (!@l) {
        ++$ok;
        return 1;
    }

    my ($raw_error, $translated) = partition { /^(badarch|bados|installed|badrelocate|conflicts|installed|diskspace|disknodes|requires|conflicts|unknown)\@/ } @l;
    @l = @$translated;
    my $fatal = find { /^disk/ } @$raw_error;
    my $no_question = $fatal || $options->{auto};

    #- Warning : the following message is parsed in urpm::parallel_*
    my $msg = N("Installation failed:") . "\n" . join("\n",  map { "\t$_" } @l) . "\n";
    if (!$no_question && !$install_options_common{nodeps} && ($options->{'allow-nodeps'} || $allow_force)) {
        if ($callbacks->{ask_yes_or_no}->(N("Installation failed"), 
                                          $msg . N("Try installation without checking dependencies?"))) {
            $urpm->{log}("starting installing packages without deps");
            $install_options_common{nodeps} = 1;
            # try again:
            goto install;
        }
    } elsif (!$no_question && !$install_options_common{force} && $allow_force) {
        if ($callbacks->{ask_yes_or_no}->(N("Installation failed"),
                                          $msg . N("Try harder to install (--force)?"))) {
            $urpm->{log}("starting force installing packages without deps");
            $install_options_common{force} = 1;
            # try again:
            goto install;
        }
    }
    $urpm->{log}($msg);

    ++$nok;
    push @$errors, @l;

    !$fatal;
}

=item run($urpm, $state, $something_was_to_be_done, $ask_unselect, $callbacks)

Run the main urpm loop:

=over

=item * mount removable media if needed

=item * split the work in smaller transactions

=item * for each transaction:

=over

=item * prepare the transaction

=item * download packages needed for this small transaction

=item * verify packages

=item * split package that should be installed instead of upgraded,

=item * install source package only (whatever the user is root or not, but use rpm for that)

=item * install/remove other packages

=back

=item * migrate the chrooted rpmdb if needed

=item * display the final success/error message(s)

=back

Warning: locking is left to callers...

Parameters:

=over

=item $urpm: the urpm object

=item $state: the state object (see L<URPM>)

=item $something_was_to_be_done

=item $ask_unselect: an array ref of packages that could not be selected

=item $callbacks: a hash ref of callbacks :

=over

=item trans_log: called for displaying download progress

=item interaction with user:

=over

=item ask_yes_or_no($_title, $msg)

=item need_restart($need_restart_formatted) called when restarting urpmi is needed (priority upgrades)

=item message($_title, $msg): display a message (with a title for GUIes)

=back

=item signature management:

=over

=item pre_check_sig(): signature checking startup (for rpmdrake)

=item check_sig(): signature checking progress (for rpmdrake)

=item bad_signature($msg, $msg2): called when a package is not/badly signed

=back

=item removable media management:

=over

=item pre_removable(): called before handling removable media (for rpmdrake)

=item copy_removable($medium_name): called for asking inserting a CD/DVD

=item post_extract($set, $transaction_sources, $transaction_sources_install) called after handling removable media (for rpmdrake)

=back

=item packages installation callbacks (passed to urpm::install::install())

=over

=item open_helper(): called when opening a package, must return a fd

=item close_helper(): called when package is closed

=item inst() called for package opening/progress/end

=item trans() called for transaction opening/progress/end

=item callback_report_uninst(): called for erasure progrses

=back

=item finish callbacks (mainly GUI callbacks for rpmdrake/gurpmi/drakx)

=over

=item completed(): called when everything is completed (for cleanups)

=item trans_error_summary($nok, $errors) called to warn than $nok transactions failed with $errors messages

=item success_summary() called on success

=item already_installed_or_not_installable($msg1, $msg2)

=back

=back

=back

=cut


sub run {
    my ($urpm, $state, $something_was_to_be_done, $ask_unselect, $callbacks) = @_;

    #- global boolean options
    ($auto_select, $no_install, $install_src, $clean, $noclean, $force, $parallel, $test) =
      ($::auto_select, $::no_install, $::install_src, $::clean, $::noclean, $::force, $::parallel, $::test);

    urpm::get_pkgs::clean_all_cache($urpm) if $clean;

    my $options = $urpm->{options};

    my ($local_sources, $blists) = urpm::get_pkgs::selected2local_and_blists($urpm,
                                                                             $state->{selected},
                                                                             clean_other => !$noclean && $options->{'pre-clean'},
                                                                         );
    if (!$local_sources && !$blists) {
        $urpm->{fatal}(3, N("unable to get source packages, aborting"));
    }

    my %sources = %$local_sources;

    _handle_removable_media($urpm, $callbacks, $blists, \%sources);

    if (exists $options->{'download-all'}) {
        _download_all($urpm, $blists, \%sources, $callbacks);
    }

    #- now create transaction just before installation, this will save user impression of slowness.
    #- split of transaction should be disabled if --test is used.
    urpm::install::build_transaction_set_($urpm, $state,
                                          nodeps => $options->{'allow-nodeps'} || $options->{'allow-force'},
                                          keep => $options->{keep},
                                          split_level => $options->{'split-level'},
                                          split_length => !$test && $options->{'split-length'});

    if ($options{debug__do_not_install}) {
	$urpm->{debug} = sub { print STDERR "$_[0]\n" };
    }

    $urpm->{debug} and $urpm->{debug}(join("\n", "scheduled sets of transactions:", 
                                           urpm::install::transaction_set_to_string($urpm, $state->{transaction} || [])));

    $options{debug__do_not_install} and exit 0;

    ($ok, $nok) = (0, 0);
    my (@errors, @formatted_errors);
    $exit_code = 0;

    my $migrate_back_rpmdb_db_version = 
      $urpm->{root} && urpm::select::should_we_migrate_back_rpmdb_db_version($urpm, $state);

    #- now process each remove/install transaction
    foreach my $set (@{$state->{transaction} || []}) {

        #- put a blank line to separate with previous transaction or user question.
        $urpm->{print}("\n") if $options{verbose} >= 0;

        my ($transaction_blists, $transaction_sources) = 
          urpm::install::prepare_transaction($set, $blists, \%sources);

        #- first, filter out what is really needed to download for this small transaction.
        my ($error_sources, $msgs) = _download_packages($urpm, $callbacks, $transaction_blists, $transaction_sources);
        if (@$error_sources) {
            $nok++;
            last if !_continue_on_error($urpm, $callbacks, $msgs, $error_sources, \@formatted_errors);
        }

        $callbacks->{post_download} and $callbacks->{post_download}->();

        #- extract packages that should be installed instead of upgraded,
        my %transaction_sources_install = %{$urpm->extract_packages_to_install($transaction_sources) || {}};
        $callbacks->{post_extract} and $callbacks->{post_extract}->($set, $transaction_sources, \%transaction_sources_install);

        #- verify packages
        if (!$force && ($options->{'verify-rpm'} || grep { $_->{'verify-rpm'} } @{$urpm->{media}})) {
            my $res = _verify_rpm($urpm, $callbacks, \%transaction_sources_install, $transaction_sources);
            $res and return $res;
        }

        #- install source package only (whatever the user is root or not, but use rpm for that).
        if ($install_src) {
            _install_src($urpm, \%transaction_sources_install, $transaction_sources);
            next;
        }

        next if $no_install;

        #- clean to remove any src package now.
        clean_trans_sources_from_src_packages($urpm, \%transaction_sources_install, $transaction_sources);

        #- install/remove other packages
        if (keys(%transaction_sources_install) || keys(%$transaction_sources) || $set->{remove}) {
            if ($parallel) {
                _run_parallel_transaction($urpm, $state, $transaction_sources, \%transaction_sources_install);
            } else {
                if ($options{verbose} >= 0) {
                    _log_installing($urpm, \%transaction_sources_install, $transaction_sources);
                }
                bug_log(scalar localtime(), " ", join(' ', values %transaction_sources_install, values %$transaction_sources), "\n");

                _run_transaction($urpm, $state, $callbacks, $set, \%transaction_sources_install, $transaction_sources, \@errors)
                   or last;
            }
        }

        last if $callbacks->{is_canceled} && $callbacks->{is_canceled}->();
    }

    #- migrate the chrooted rpmdb if needed
    if ($migrate_back_rpmdb_db_version) {
        urpm::sys::migrate_back_rpmdb_db_version($urpm, $urpm->{root});
    }

    $callbacks->{completed} and $callbacks->{completed}->();

    _finish($urpm, $state, $callbacks, \@errors, \@formatted_errors, $ask_unselect, $something_was_to_be_done);

    $exit_code;
}

sub _finish {
    my ($urpm, $state, $callbacks, $errors, $formatted_errors, $ask_unselect, $something_was_to_be_done) = @_;

    if ($nok) {
        $callbacks->{trans_error_summary} and $callbacks->{trans_error_summary}->($nok, $errors);
        if (@$formatted_errors) {
            $urpm->{print}(join("\n", @$formatted_errors));
        }
        if (@$errors) {
            $urpm->{print}(N("Installation failed:") . join("\n", map { "\t$_" } @$errors));
        }
        $exit_code ||= $ok ? 11 : 12;
    } else {
        $callbacks->{success_summary} and $callbacks->{success_summary}->();
        if ($something_was_to_be_done || $auto_select) {
            if (@{$state->{transaction} || []} == 0 && @$ask_unselect == 0) {
                if ($auto_select) {
                    if ($options{verbose} >= 0) {
                        #- Warning : the following message is parsed in urpm::parallel_*
                        $urpm->{print}(N("Packages are up to date"));
                    }
                } else {
                    if ($callbacks->{already_installed_or_not_installable}) {
                        my $msg = urpm::select::translate_already_installed($state);
                        $callbacks->{already_installed_or_not_installable}->([$msg], []);
                    }
                }
                $exit_code = 15 if our $expect_install;
            } elsif ($test && $exit_code == 0) {
                #- Warning : the following message is parsed in urpm::parallel_*
                print N("Installation is possible"), "\n";
            } else {
                handle_need_restart($urpm, $state, $callbacks);
            }
        }
    }
    $exit_code;
}

sub handle_need_restart {
    my ($urpm, $state, $callbacks) = @_;

    return if $urpm->{root} && !$ENV{URPMI_TEST_RESTART};
    return if !$callbacks->{need_restart};

    if (intersection([ keys %{$state->{selected}} ],
                     [ keys %{$urpm->{provides}{'should-restart'}} ])) {
        if (my $need_restart_formatted = urpm::sys::need_restart_formatted($urpm->{root})) {
            $callbacks->{need_restart}($need_restart_formatted);

            # need_restart() accesses rpm db, so we need to ensure things are clean:
            urpm::sys::may_clean_rpmdb_shared_regions($urpm, $options{test});
        }
    }
}

1;

=back

=head1 COPYRIGHT

Copyright (C) 1999-2005 MandrakeSoft SA

Copyright (C) 2005-2010 Mandriva SA

Copyright (C) 2011-2013 Mageia

=cut
opt">; if (/\|/) { #- this package use a choice of other package, so we have to check #- if our package is not included in the choice, if this is the #- case, if must be checked one of the other package are selected. foreach (split '\|') { my $dep = packageById($packages, $_); $dep == $pkg and $unselect_alone |= 1 and next; packageFlagBase($dep) || packageFlagSelected($dep) and $unselect_alone |= 2; } } else { packageById($packages, $_) == $pkg and $unselect_alone = 1; } $unselect_alone == 1 and last; } #- if package has been found and nothing more selected, #- deselect the provided, or we can ignore it safely. $provided == $pkg || $unselect_alone == 1 or next; $otherOnly or packageSetFlagSelected($provided, 0); $otherOnly and $otherOnly->{packageName($provided)} = 1; } foreach (map { split '\|' } packageDepsId($provided)) { my $dep = packageById($packages, $_); packageFlagBase($dep) and next; packageFlagSelected($dep) or next; for (packageFlagSelected($dep)) { $_ == 1 and do { $otherOnly and $otherOnly->{packageName($dep)} ||= 0; }; $_ > 1 and do { $otherOnly or packageSetFlagSelected($dep, $_-1); }; last; } } } 1; } sub togglePackageSelection($$;$) { my ($packages, $pkg, $otherOnly) = @_; packageFlagSelected($pkg) ? unselectPackage($packages, $pkg, $otherOnly) : selectPackage($packages, $pkg, 0, $otherOnly); } sub setPackageSelection($$$) { my ($packages, $pkg, $value) = @_; $value ? selectPackage($packages, $pkg) : unselectPackage($packages, $pkg); } sub unselectAllPackages($) { my ($packages) = @_; foreach (values %{$packages->{names}}) { unless (packageFlagBase($_) || packageFlagUpgrade($_)) { packageSetFlagSelected($_, 0); } } } sub unselectAllPackagesIncludingUpgradable($) { my ($packages, $removeUpgradeFlag) = @_; foreach (values %{$packages->{names}}) { unless (packageFlagBase($_)) { packageSetFlagSelected($_, 0); packageSetFlagUpgrade($_, 0); } } } sub psUpdateHdlistsDeps { my ($prefix, $method) = @_; my $listf = install_any::getFile('Mandrake/base/hdlists') or die "no hdlists found"; #- WARNING: this function should be kept in sync with functions #- psUsingHdlists and psUsingHdlist. #- it purpose it to update hdlist files on system to install. #- parse hdlist.list file. my $medium = 1; foreach (<$listf>) { chomp; s/\s*#.*$//; /^\s*$/ and next; m/^\s*(hdlist\S*\.cz2?)\s+(\S+)\s*(.*)$/ or die "invalid hdlist description \"$_\" in hdlists file"; my ($hdlist, $rpmsdir, $descr) = ($1, $2, $3); #- copy hdlist file directly to $prefix/var/lib/urpmi, this will be used #- for getting header of package during installation or after by urpmi. my $fakemedium = "$descr ($method$medium)"; my $newf = "$prefix/var/lib/urpmi/hdlist.$fakemedium.cz" . ($hdlist =~ /\.cz2/ && "2"); -e $newf and do { unlink $newf or die "cannot remove $newf: $!"; }; install_any::getAndSaveFile("Mandrake/base/$hdlist", $newf) or die "no $hdlist found"; symlinkf $newf, "/tmp/$hdlist"; ++$medium; } #- this is necessary for urpmi. install_any::getAndSaveFile("Mandrake/base/$_", "$prefix/var/lib/urpmi/$_") foreach qw(depslist.ordered provides rpmsrate); } sub psUsingHdlists { my ($prefix, $method) = @_; my $listf = install_any::getFile('Mandrake/base/hdlists') or die "no hdlists found"; my %packages = ( names => {}, depslist => [], mediums => {}); #- parse hdlists file. my $medium = 1; foreach (<$listf>) { chomp; s/\s*#.*$//; /^\s*$/ and next; m/^\s*(hdlist\S*\.cz2?)\s+(\S+)\s*(.*)$/ or die "invalid hdlist description \"$_\" in hdlists file"; #- make sure the first medium is always selected! #- by default select all image. psUsingHdlist($prefix, $method, \%packages, $1, $medium, $2, $3, 1); ++$medium; } log::l("psUsingHdlists read " . scalar keys(%{$packages{names}}) . " headers on " . scalar keys(%{$packages{mediums}}) . " hdlists"); \%packages; } sub psUsingHdlist { my ($prefix, $method, $packages, $hdlist, $medium, $rpmsdir, $descr, $selected, $fhdlist) = @_; my $fakemedium = "$descr ($method$medium)"; log::l("trying to read $hdlist for medium $medium"); #- if the medium already exist, use it. $packages->{mediums}{$medium} and return; my $m = $packages->{mediums}{$medium} = { hdlist => $hdlist, method => $method, medium => $medium, rpmsdir => $rpmsdir, #- where is RPMS directory. descr => $descr, fakemedium => $fakemedium, min => scalar keys %{$packages->{names}}, max => -1, #- will be updated after reading current hdlist. selected => $selected, #- default value is only CD1, it is really the minimal. }; #- copy hdlist file directly to $prefix/var/lib/urpmi, this will be used #- for getting header of package during installation or after by urpmi. my $newf = "$prefix/var/lib/urpmi/hdlist.$fakemedium.cz" . ($hdlist =~ /\.cz2/ && "2"); -e $newf and do { unlink $newf or die "cannot remove $newf: $!"; }; install_any::getAndSaveFile($fhdlist || "Mandrake/base/$hdlist", $newf) or die "no $hdlist found"; symlinkf $newf, "/tmp/$hdlist"; #- avoid using more than one medium if Cd is not ejectable. #- but keep all medium here so that urpmi has the whole set. $method eq 'cdrom' && $medium > 1 && isCdNotEjectable() and return; #- extract filename from archive, this take advantage of verifying #- the archive too. eval { require packdrake; my $packer = new packdrake($newf, quiet => 1); foreach (@{$packer->{files}}) { $packer->{data}{$_}[0] eq 'f' or next; my $pkg = [ (undef) x 8 ]; $pkg->[$FILE] = $_; $pkg->[$MEDIUM] = $m; my $specific_arch = packageArch($pkg); if (!$specific_arch || compat_arch($specific_arch)) { my $old_pkg = $packages->{names}{packageName($pkg)}; if ($old_pkg) { if (packageVersion($pkg) eq packageVersion($old_pkg) && packageRelease($pkg) eq packageRelease($old_pkg)) { if (better_arch($specific_arch, packageArch($old_pkg))) { log::l("replacing old package with package $_ with better arch: $specific_arch"); $packages->{names}{packageName($pkg)} = $pkg; } else { log::l("keeping old package against package $_ with worse arch"); } } else { log::l("ignoring package $_ already present in distribution with different version or release"); } } else { $packages->{names}{packageName($pkg)} = $pkg; } } else { log::l("ignoring package $_ with incompatible arch: $specific_arch"); } } }; #- update maximal index. $m->{max} = scalar(keys %{$packages->{names}}) - 1; $m->{max} >= $m->{min} or die "nothing found while parsing $newf"; log::l("read " . ($m->{max} - $m->{min} + 1) . " headers in $hdlist"); 1; } sub getOtherDeps($$) { my ($packages, $f) = @_; #- this version of getDeps is customized for handling errors more easily and #- convert reference by name to deps id including closure computation. local $_; while (<$f>) { my ($name, $version, $release, $size, $deps) = /^(\S*)-([^-\s]+)-([^-\s]+)\s+(\d+)\s+(.*)/; my $pkg = $packages->{names}{$name}; $pkg or log::l("ignoring package $name-$version-$release in depslist is not in hdlist"), next; $version eq packageVersion($pkg) and $release eq packageRelease($pkg) or log::l("warning package $name-$version-$release in depslist mismatch version or release in hdlist ($version ne ", packageVersion($pkg), " or $release ne ", packageRelease($pkg), ")"), next; my $index = scalar @{$packages->{depslist}}; $index >= $pkg->[$MEDIUM]{min} && $index <= $pkg->[$MEDIUM]{max} or log::l("ignoring package $name-$version-$release in depslist outside of hdlist indexation"); #- here we have to translate referenced deps by name to id. #- this include a closure on deps too. my %closuredeps; @closuredeps{map { packageId($packages, $_), packageDepsId($_) } grep { $_ } map { packageByName($packages, $_) or do { log::l("unknown package $_ in depslist for closure"); undef } } split /\s+/, $deps} = (); $pkg->[$SIZE_DEPS] = join " ", $size, keys %closuredeps; push @{$packages->{depslist}}, $pkg; } #- check for same number of package in depslist and hdlists, avoid being to hard. scalar(keys %{$packages->{names}}) == scalar(@{$packages->{depslist}}) or log::l("other depslist has not same package as hdlist file"); } sub getDeps { my ($prefix, $packages) = @_; #- this is necessary for urpmi. install_any::getAndSaveFile('Mandrake/base/depslist.ordered', "$prefix/var/lib/urpmi/depslist.ordered"); install_any::getAndSaveFile('Mandrake/base/provides', "$prefix/var/lib/urpmi/provides"); #- beware of heavily mismatching depslist.ordered file against hdlist files. my $mismatch = 0; #- update dependencies list, provides attributes are updated later #- cross reference to be resolved on id (think of loop requires) #- provides should be updated after base flag has been set to save #- memory. local *F; open F, "$prefix/var/lib/urpmi/depslist.ordered" or die "can't find dependancies list"; local $_; while (<F>) { my ($name, $version, $release, $sizeDeps) = /^(\S*)-([^-\s]+)-([^-\s]+)\s+(.*)/; my $pkg = $packages->{names}{$name}; #- these verification are necessary in case of error, but are no more fatal as #- in case of only one medium taken into account during install, there should be #- silent warning for package which are unknown at this point. $pkg or log::l("ignoring $name-$version-$release in depslist is not in hdlist"), next; $version eq packageVersion($pkg) or log::l("ignoring $name-$version-$release in depslist mismatch version in hdlist"), next; $release eq packageRelease($pkg) or log::l("ignoring $name-$version-$release in depslist mismatch release in hdlist"), next; $pkg->[$SIZE_DEPS] = $sizeDeps; #- check position of package in depslist according to precomputed #- limit by hdlist, very strict :-) #- above warning have chance to raise an exception here, but may help #- for debugging. my $i = scalar @{$packages->{depslist}}; $i >= $pkg->[$MEDIUM]{min} && $i <= $pkg->[$MEDIUM]{max} or log::l("inconsistency in position for $name-$version-$release in depslist and hdlist"), $mismatch = 1; #- package are already sorted in depslist to enable small transaction and multiple medium. push @{$packages->{depslist}}, $pkg; } #- check for mismatching package, it should break with above die unless depslist has too many errors! $mismatch and die "depslist.ordered mismatch against hdlist files"; #- check for same number of package in depslist and hdlists. scalar(keys %{$packages->{names}}) == scalar(@{$packages->{depslist}}) or die "depslist.ordered has not same package as hdlist files"; } sub getProvides($) { my ($packages) = @_; #- update provides according to dependencies, here are stored #- reference to package directly and choice are included, this #- assume only 1 of the choice is selected, else on unselection #- the provided package will be deleted where other package still #- need it. #- base package are not updated because they cannot be unselected, #- this save certainly a lot of memory since most of them may be #- needed by a large number of package. #- now using a packed of signed short, this means no more than 32768 #- packages can be managed by DrakX (currently about 2000). my $i = 0; foreach my $pkg (@{$packages->{depslist}}) { unless (packageFlagBase($pkg)) { foreach (map { split '\|' } grep { !/^NOTFOUND_/ } packageDepsId($pkg)) { my $provided = $packages->{depslist}[$_] or die "invalid package index $_"; packageFlagBase($provided) or $provided->[$PROVIDES] = pack "s*", (unpack "s*", $provided->[$PROVIDES]), $i; } } ++$i; } } sub read_rpmsrate { my ($packages, $f) = @_; my $line_nb = 0; my (@l); while (<$f>) { $line_nb++; /\t/ and die "tabulations not allowed at line $line_nb\n"; s/#.*//; # comments my ($indent, $data) = /(\s*)(.*)/; next if !$data; # skip empty lines @l = grep { $_->[0] < length $indent } @l; my @m = @l ? @{$l[$#l][1]} : (); my ($t, $flag, @l2); while ($data =~ /^(( [1-5] | (?: (?: !\s*)? [0-9A-Z_]+(?:".*?")?) (?: \s*\|\|\s* (?: !\s*)? [0-9A-Z_]+(?:".*?")?)* ) (?:\s+|$) )(.*)/x) { #@")) { ($t, $flag, $data) = ($1,$2,$3); while ($flag =~ s,^\s*(("[^"]*"|[^"\s]*)*)\s+,$1,) {} my $ok = 0; $flag = join('||', grep { if (my ($inv, $p) = /^(!)?HW"(.*)"/) { ($inv xor detect_devices::matching_desc($p)) and $ok = 1; 0; } else { 1; } } split '\|\|', $flag); push @m, $ok ? 'TRUE' : $flag || 'FALSE'; push @l2, [ length $indent, [ @m ] ]; $indent .= $t; } if ($data) { # has packages on same line my ($rate) = grep { /^\d$/ } @m or die sprintf qq(missing rate for "%s" at line %d (flags are %s)\n), $data, $line_nb, join('&&', @m); foreach (split ' ', $data) { if ($packages) { my $p = packageByName($packages, $_) or next; my @m2 = map { packageName(packageById($packages, $_)) =~ /locales-(.*)/ ? qq(LOCALES"$1") : () } packageDepsId($p); packageSetRateRFlags($p, $rate, (grep { !/^\d$/ } @m), @m2); } else { print "$_ = ", join(" && ", @m), "\n"; } } push @l, @l2; } else { push @l, [ $l2[0][0], $l2[$#l2][1] ]; } } } sub readCompssUsers { my ($meta_class) = @_; my (%compssUsers, @sorted, $l); my $file = 'Mandrake/base/compssUsers'; my $f = $meta_class && install_any::getFile("$file.$meta_class") || install_any::getFile($file) or die "can't find $file"; local $_; while (<$f>) { /^\s*$/ || /^#/ and next; s/#.*//; if (/^(\S.*)/) { my $verbatim = $_; my ($icon, $descr, $path); /^(.*?)\s*\[path=(.*?)\](.*)/ and $_ = "$1$3", $path = $2; /^(.*?)\s*\[icon=(.*?)\](.*)/ and $_ = "$1$3", $icon = $2; /^(.*?)\s*\[descr=(.*?)\](.*)/ and $_ = "$1$3", $descr = $2; $compssUsers{"$path|$_"} = { label => $_, verbatim => $verbatim, path => $path, icons => $icon, descr => $descr, flags => $l=[] }; push @sorted, "$path|$_"; } elsif (/^\s+(.*?)\s*$/) { push @$l, $1; } } \%compssUsers, \@sorted; } sub saveCompssUsers { my ($prefix, $packages, $compssUsers, $sorted) = @_; my $flat; foreach (@$sorted) { my @fl = @{$compssUsers->{$_}{flags}}; my %fl; $fl{$_} = 1 foreach @fl; $flat .= $compssUsers->{$_}{verbatim}; foreach my $p (values %{$packages->{names}}) { my ($rate, @flags) = packageRateRFlags($p); if ($rate && grep { grep { !/^!/ && $fl{$_} } split('\|\|') } @flags) { $flat .= sprintf "\t%d %s\n", $rate, packageName($p); } } } output "$prefix/var/lib/urpmi/compssUsers.flat", $flat; } sub setSelectedFromCompssList { my ($packages, $compssUsersChoice, $min_level, $max_size) = @_; $compssUsersChoice->{TRUE} = 1; #- ensure TRUE is set my $nb = selectedSize($packages); foreach my $p (sort { packageRate($b) <=> packageRate($a) } values %{$packages->{names}}) { my ($rate, @flags) = packageRateRFlags($p); next if !$rate || $rate < $min_level || grep { !grep { /^!(.*)/ ? !$compssUsersChoice->{$1} : $compssUsersChoice->{$_} } split('\|\|') } @flags; #- determine the packages that will be selected when #- selecting $p. the packages are not selected. my %newSelection; selectPackage($packages, $p, 0, \%newSelection); #- this enable an incremental total size. my $old_nb = $nb; foreach (grep { $newSelection{$_} } keys %newSelection) { $nb += packageSize($packages->{names}{$_}); } if ($max_size && $nb > $max_size) { $nb = $old_nb; $min_level = packageRate($p); last; } #- at this point the package can safely be selected. selectPackage($packages, $p); } log::l("setSelectedFromCompssList: reached size ", formatXiB($nb), ", up to indice $min_level (less than ", formatXiB($max_size), ")"); log::l("setSelectedFromCompssList: ", join(" ", sort map { packageName($_) } grep { packageFlagSelected($_) } @{$packages->{depslist}})); $min_level; } #- usefull to know the size it would take for a given min_level/max_size #- just saves the selected packages, call setSelectedFromCompssList and restores the selected packages sub saveSelected { my ($packages) = @_; my @l = values %{$packages->{names}}; my @flags = map { packageFlagSelected($_) } @l; [ $packages, \@l, \@flags ]; } sub restoreSelected { my ($packages, $l, $flags) = @{$_[0]}; mapn { packageSetFlagSelected(@_) } $l, $flags; } sub computeGroupSize { my ($packages, $min_level) = @_; sub inside { my ($l1, $l2) = @_; my $i = 0; return if @$l1 > @$l2; foreach (@$l1) { my $c; while ($c = $l2->[$i++] cmp $_ ) { return if $c == 1 || $i > @$l2; } } 1; } sub or_ify { my ($first, @other) = @_; my @l = split('\|\|', $first); foreach (@other) { @l = map { my $n = $_; map { "$_&&$n" } @l; } split('\|\|'); } #- HACK, remove LOCALES, too costly grep { !/LOCALES/ } @l; } sub or_clean { my (@l) = map { [ sort split('&&') ] } @_ or return ''; my @r; B: while (@l) { my $e = shift @l; foreach (@r, @l) { inside($e, $_) and next B; } push @r, $e; } join("\t", map { join('&&', @$_) } @r); } my (%group, %memo); foreach my $p (values %{$packages->{names}}) { my ($rate, @flags) = packageRateRFlags($p); next if !$rate || $rate < $min_level; my $flags = join("\t", @flags = or_ify(@flags)); $group{packageName($p)} = ($memo{$flags} ||= or_clean(@flags)); #- determine the packages that will be selected when selecting $p. the packages are not selected. my %newSelection; selectPackage($packages, $p, 0, \%newSelection); foreach (grep { $newSelection{$_} } keys %newSelection) { my $s = $group{$_} || do { $packages->{names}{$_}[$VALUES] =~ /\t(.*)/; join("\t", or_ify(split("\t", $1))); }; next if length($s) > 80; # HACK, truncated too complicated expressions, too costly my $m = "$flags\t$s"; $group{$_} = ($memo{$m} ||= or_clean(@flags, split("\t", $s))); } } my (%sizes, %pkgs); while (my ($k, $v) = each %group) { push @{$pkgs{$v}}, $k; $sizes{$v} += packageSize($packages->{names}{$k}); } log::l(sprintf "%s %dMB %s", $_, $sizes{$_} / sqr(1024), join(',', @{$pkgs{$_}})) foreach keys %sizes; \%sizes, \%pkgs; } sub init_db { my ($prefix) = @_; my $f = "$prefix/root/install.log"; open(LOG, "> $f") ? log::l("opened $f") : log::l("Failed to open $f. No install log will be kept."); *LOG or *LOG = log::F() or *LOG = *STDERR; CORE::select((CORE::select(LOG), $| = 1)[0]); c::rpmErrorSetCallback(fileno LOG); #- c::rpmSetVeryVerbose(); log::l("reading /usr/lib/rpm/rpmrc"); c::rpmReadConfigFiles() or die "can't read rpm config files"; log::l("\tdone"); } sub rebuild_db_open_for_traversal { my ($packages, $prefix) = @_; log::l("reading /usr/lib/rpm/rpmrc"); c::rpmReadConfigFiles() or die "can't read rpm config files"; log::l("\tdone"); unless (exists $packages->{rebuild_db}) { if (my $pid = fork()) { waitpid $pid, 0; ($? & 0xff00) and die "rebuilding of rpm database failed"; } else { log::l("rebuilding rpm database"); my $rebuilddb_dir = "$prefix/var/lib/rpmrebuilddb.$$"; -d $rebuilddb_dir and log::l("removing stale directory $rebuilddb_dir"), commands::rm("-rf", $rebuilddb_dir); c::rpmdbRebuild($prefix) or log::l("rebuilding of rpm database failed: ". c::rpmErrorString()), c::_exit(2); c::_exit(0); } $packages->{rebuild_db} = undef; } my $db = c::rpmdbOpenForTraversal($prefix) or die "unable to open $prefix/var/lib/rpm/Packages"; log::l("opened rpm database for examining existing packages"); $db; } sub clean_old_rpm_db { my ($prefix) = @_; my $failed; foreach (qw(Basenames Conflictname Group Name Packages Providename Requirename Triggername)) { -s "$prefix/var/lib/rpm/$_" or $failed = 'failed'; } #- rebuilding has been successfull, so remove old rpm database if any. #- once we have checked the rpm4 db file are present and not null, in case #- of doubt, avoid removing them... unless ($failed) { log::l("rebuilding rpm database completed successfully"); foreach (qw(conflictsindex.rpm fileindex.rpm groupindex.rpm nameindex.rpm packages.rpm providesindex.rpm requiredby.rpm triggerindex.rpm)) { -e "$prefix/var/lib/rpm/$_" or next; log::l("removing old rpm file $_"); commands::rm("-f", "$prefix/var/lib/rpm/$_"); } } } sub done_db { log::l("closing install.log file"); close LOG; } sub versionCompare($$) { my ($a, $b) = @_; local $_; while ($a || $b) { my ($sb, $sa) = map { $1 if $a =~ /^\W*\d/ ? s/^\W*0*(\d+)// : s/^\W*(\D*)// } ($b, $a); $_ = length($sa) <=> length($sb) || $sa cmp $sb and return $_; $sa eq '' && $sb eq '' and return $a cmp $b || 0; } } sub selectPackagesAlreadyInstalled { my ($packages, $prefix) = @_; #- avoid rebuilding the database if such case. $packages->{rebuild_db} = "oem does not need rebuilding the rpm db"; my $db = rebuild_db_open_for_traversal($packages, $prefix); #- this method has only one objectif, check the presence of packages #- already installed and avoid installing them again. this is to be used #- with oem installation, if the database exists, preselect the packages #- installed WHATEVER their version/release (log if a problem is perceived #- is enough). c::rpmdbTraverse($db, sub { my ($header) = @_; my $p = $packages->{names}{c::headerGetEntry($header, 'name')}; if ($p) { my $version_cmp = versionCompare(c::headerGetEntry($header, 'version'), packageVersion($p)); my $version_rel_test = $version_cmp > 0 || $version_cmp == 0 && versionCompare(c::headerGetEntry($header, 'release'), packageRelease($p)) >= 0; $version_rel_test or log::l("keeping an older package, avoiding selecting $p->[$FILE]"); packageSetFlagInstalled($p, 1); } }); #- close db, job finished ! c::rpmdbClose($db); log::l("done selecting packages to upgrade"); } sub selectPackagesToUpgrade($$$;$$) { my ($packages, $prefix, $base, $toRemove, $toSave) = @_; local $_; #- else perl complains on the map { ... } grep { ... } @...; local (*UPGRADE_INPUT, *UPGRADE_OUTPUT); pipe UPGRADE_INPUT, UPGRADE_OUTPUT; if (my $pid = fork()) { @{$toRemove || []} = (); #- reset this one. close UPGRADE_OUTPUT; while (<UPGRADE_INPUT>) { chomp; my ($action, $name) = /^([\w\d]*):(.*)/; for ($action) { /remove/ and do { push @$toRemove, $name; next }; /keepfiles/ and do { push @$toSave, $name; next }; my $p = $packages->{names}{$name} or die "unable to find package ($name)"; /^\d*$/ and do { $p->[$INSTALLED_CUMUL_SIZE] = $action; next }; /installed/ and do { packageSetFlagInstalled($p, 1); next }; /select/ and do { selectPackage($packages, $p); next }; die "unknown action ($action)"; } } close UPGRADE_INPUT; waitpid $pid, 0; } else { close UPGRADE_INPUT; my $db = rebuild_db_open_for_traversal($packages, $prefix); #- used for package that are not correctly updated. #- should only be used when nothing else can be done correctly. my %upgradeNeedRemove = ( 'libstdc++' => 1, 'compat-glibc' => 1, 'compat-libs' => 1, ); #- generel purpose for forcing upgrade of package whatever version is. my %packageNeedUpgrade = ( 'lilo' => 1, #- this package has been misnamed in 7.0. ); #- help removing package which may have different release numbering my %toRemove; map { $toRemove{$_} = 1 } @{$toRemove || []}; #- help searching package to upgrade in regard to already installed files. my %installedFilesForUpgrade; #- help keeping memory by this set of package that have been obsoleted. my %obsoletedPackages; #- make a subprocess here for reading filelist, this is important #- not to waste a lot of memory for the main program which will fork #- latter for each transaction. local (*INPUT, *OUTPUT_CHILD); pipe INPUT, OUTPUT_CHILD; local (*INPUT_CHILD, *OUTPUT); pipe INPUT_CHILD, OUTPUT; if (my $pid = fork()) { close INPUT_CHILD; close OUTPUT_CHILD; select((select(OUTPUT), $| = 1)[0]); #- internal reading from interactive mode of parsehdlist. #- takes a code to call with the line read, this avoid allocating #- memory for that. my $ask_child = sub { my ($name, $tag, $code) = @_; $code or die "no callback code for parsehdlist output"; print OUTPUT "$name:$tag\n"; local $_; while (<INPUT>) { chomp; /^\s*$/ and last; $code->($_); } }; #- select packages which obseletes other package, obselete package are not removed, #- should we remove them ? this could be dangerous ! foreach my $p (values %{$packages->{names}}) { $ask_child->(packageName($p), "obsoletes", sub { #- take care of flags and version and release if present if ($_[0] =~ /^(\S*)\s*(\S*)\s*([^\s-]*)-?(\S*)/ && c::rpmdbNameTraverse($db, $1) > 0) { $3 and eval(versionCompare(packageVersion($p), $3) . $2 . 0) or next; $4 and eval(versionCompare(packageRelease($p), $4) . $2 . 0) or next; log::l("selecting " . packageName($p) . " by selection on obsoletes"); $obsoletedPackages{$1} = undef; selectPackage($packages, $p); } }); } #- mark all files which are not in /etc/rc.d/ for packages which are already installed but which #- are not in the packages list to upgrade. #- the 'installed' property will make a package unable to be selected, look at select. c::rpmdbTraverse($db, sub { my ($header) = @_; my $otherPackage = (c::headerGetEntry($header, 'release') !~ /mdk\w*$/ && (c::headerGetEntry($header, 'name'). '-' . c::headerGetEntry($header, 'version'). '-' . c::headerGetEntry($header, 'release'))); my $p = $packages->{names}{c::headerGetEntry($header, 'name')}; if ($p) { my $version_cmp = versionCompare(c::headerGetEntry($header, 'version'), packageVersion($p)); my $version_rel_test = $version_cmp > 0 || $version_cmp == 0 && versionCompare(c::headerGetEntry($header, 'release'), packageRelease($p)) >= 0; if ($packageNeedUpgrade{packageName($p)}) { log::l("package ". packageName($p) ." need to be upgraded"); } elsif ($version_rel_test) { #- by default, package are upgraded whatever version is ! if ($otherPackage && $version_cmp <= 0) { log::l("force upgrading $otherPackage since it will not be updated otherwise"); } else { #- let the parent known this installed package. print UPGRADE_OUTPUT "installed:" . packageName($p) . "\n"; packageSetFlagInstalled($p, 1); } } elsif ($upgradeNeedRemove{packageName($p)}) { my $otherPackage = (c::headerGetEntry($header, 'name'). '-' . c::headerGetEntry($header, 'version'). '-' . c::headerGetEntry($header, 'release')); log::l("removing $otherPackage since it will not upgrade correctly!"); $toRemove{$otherPackage} = 1; #- force removing for theses other packages, select our. } } else { if (! exists $obsoletedPackages{c::headerGetEntry($header, 'name')}) { my @files = c::headerGetEntry($header, 'filenames'); @installedFilesForUpgrade{grep { ($_ !~ m|^/etc/rc.d/| && $_ !~ m|\.la$| && ! -d "$prefix/$_" && ! -l "$prefix/$_") } @files} = (); } } }); #- find new packages to upgrade. foreach my $p (values %{$packages->{names}}) { my $skipThis = 0; my $count = c::rpmdbNameTraverse($db, packageName($p), sub { my ($header) = @_; $skipThis ||= packageFlagInstalled($p); }); #- skip if not installed (package not found in current install). $skipThis ||= ($count == 0); #- make sure to upgrade package that have to be upgraded. $packageNeedUpgrade{packageName($p)} and $skipThis = 0; #- select the package if it is already installed with a lower version or simply not installed. unless ($skipThis) { my $cumulSize; selectPackage($packages, $p); #- keep in mind installed files which are not being updated. doing this costs in #- execution time but use less memory, else hash all installed files and unhash #- all file for package marked for upgrade. c::rpmdbNameTraverse($db, packageName($p), sub { my ($header) = @_; $cumulSize += c::headerGetEntry($header, 'size'); my @files = c::headerGetEntry($header, 'filenames'); @installedFilesForUpgrade{grep { ($_ !~ m|^/etc/rc.d/| && $_ !~ m|\.la$| && ! -d "$prefix/$_" && ! -l "$prefix/$_") } @files} = (); }); $ask_child->(packageName($p), "files", sub { delete $installedFilesForUpgrade{$_[0]}; }); #- keep in mind the cumul size of installed package since they will be deleted #- on upgrade, only for package that are allowed to be upgraded. if (allowedToUpgrade(packageName($p))) { print UPGRADE_OUTPUT "$cumulSize:" . packageName($p) . "\n"; } } } #- unmark all files for all packages marked for upgrade. it may not have been done above #- since some packages may have been selected by depsList. foreach my $p (values %{$packages->{names}}) { if (packageFlagSelected($p)) { $ask_child->(packageName($p), "files", sub { delete $installedFilesForUpgrade{$_[0]}; }); } } #- select packages which contains marked files, then unmark on selection. #- a special case can be made here, the selection is done only for packages #- requiring locales if the locales are selected. #- another special case are for devel packages where fixes over the time has #- made some files moving between the normal package and its devel couterpart. #- if only one file is affected, no devel package is selected. foreach my $p (values %{$packages->{names}}) { unless (packageFlagSelected($p)) { my $toSelect = 0; $ask_child->(packageName($p), "files", sub { if ($_[0] !~ m|^/etc/rc.d/| && $_ !~ m|\.la$| && exists $installedFilesForUpgrade{$_[0]}) { ++$toSelect if ! -d "$prefix/$_[0]" && ! -l "$prefix/$_[0]"; } delete $installedFilesForUpgrade{$_[0]}; }); if ($toSelect) { if ($toSelect <= 1 && packageName($p) =~ /-devel/) { log::l("avoid selecting " . packageName($p) . " as not enough files will be updated"); } else { #- default case is assumed to allow upgrade. my @deps = map { my $p = $packages->{depslist}[$_]; $p && packageName($p) =~ /locales-/ ? ($p) : () } packageDepsId($p); if (@deps == 0 || @deps > 0 && (grep { !packageFlagSelected($_) } @deps) == 0) { log::l("selecting " . packageName($p) . " by selection on files"); selectPackage($packages, $p); } else { log::l("avoid selecting " . packageName($p) . " as its locales language is not already selected"); } } } } } #- clean memory... %installedFilesForUpgrade = (); #- no need to still use the child as this point, we can let him to terminate. close OUTPUT; close INPUT; waitpid $pid, 0; } else { close INPUT; close OUTPUT; open STDIN, "<&INPUT_CHILD"; open STDOUT, ">&OUTPUT_CHILD"; exec if_($ENV{LD_LOADER}, $ENV{LD_LOADER}), "parsehdlist", "--interactive", map { "/tmp/$_->{hdlist}" } values %{$packages->{mediums}} or c::_exit(1); } #- let the parent known about what we found here! foreach my $p (values %{$packages->{names}}) { print UPGRADE_OUTPUT "select:" . packageName($p) . "\n" if packageFlagSelected($p); } #- clean false value on toRemove. delete $toRemove{''}; #- get filenames that should be saved for packages to remove. #- typically config files, but it may broke for packages that #- are very old when compabilty has been broken. #- but new version may saved to .rpmnew so it not so hard ! if ($toSave && keys %toRemove) { c::rpmdbTraverse($db, sub { my ($header) = @_; my $otherPackage = (c::headerGetEntry($header, 'name'). '-' . c::headerGetEntry($header, 'version'). '-' . c::headerGetEntry($header, 'release')); if ($toRemove{$otherPackage}) { print UPGRADE_OUTPUT "remove:$otherPackage\n"; if (packageFlagBase($packages->{names}{c::headerGetEntry($header, 'name')})) { delete $toRemove{$otherPackage}; #- keep it selected, but force upgrade. } else { my @files = c::headerGetEntry($header, 'filenames'); my @flags = c::headerGetEntry($header, 'fileflags'); for my $i (0..$#flags) { if ($flags[$i] & c::RPMFILE_CONFIG()) { print UPGRADE_OUTPUT "keepfiles:$files[$i]\n" unless $files[$i] =~ /kdelnk/; } } } } }); } #- close db, job finished ! c::rpmdbClose($db); log::l("done selecting packages to upgrade"); close UPGRADE_OUTPUT; c::_exit(0); } #- keep a track of packages that are been selected for being upgraded, #- these packages should not be unselected (unless expertise) foreach my $p (values %{$packages->{names}}) { packageSetFlagUpgrade($p, 1) if packageFlagSelected($p); } } sub allowedToUpgrade { $_[0] !~ /^(kernel|kernel-secure|kernel-smp|kernel-linus|hackkernel)$/ } sub installCallback { # my $msg = shift; # log::l($msg .": ". join(',', @_)); } sub install($$$;$$) { my ($prefix, $isUpgrade, $toInstall, $depOrder, $media) = @_; my %packages; return if $::g_auto_install || !scalar(@$toInstall); #- for root loopback'ed /boot my $loop_boot = loopback::prepare_boot($prefix); #- first stage to extract some important informations #- about the packages selected. this is used to select #- one or many transaction. my ($total, $nb); foreach my $pkg (@$toInstall) { $packages{packageName($pkg)} = $pkg; $nb++; $total += packageSize($pkg); } log::l("pkgs::install $prefix"); log::l("pkgs::install the following: ", join(" ", keys %packages)); eval { fs::mount("/proc", "$prefix/proc", "proc", 0) } unless -e "$prefix/proc/cpuinfo"; log::l("reading /usr/lib/rpm/rpmrc"); c::rpmReadConfigFiles() or die "can't read rpm config files"; log::l("\tdone"); my $callbackOpen = sub { my $p = $packages{$_[0]}; my $f = packageFile($p); print LOG "$f $p->[$MEDIUM]{descr}\n"; my $fd = install_any::getFile($f, $p->[$MEDIUM]{descr}); $fd ? fileno $fd : -1; }; my $callbackClose = sub { packageSetFlagInstalled(delete $packages{$_[0]}, 1) }; #- do not modify/translate the message used with installCallback since #- these are keys during progressing installation, or change in other #- place (install_steps_gtk.pm,...). installCallback("Starting installation", $nb, $total); my ($i, $min, $medium) = (0, 0, 1); do { my @transToInstall; if (!$depOrder || !$media) { @transToInstall = values %packages; $nb = 0; } else { do { #- change current media if needed. if ($i > $media->{$medium}{max}) { #- search for media that contains the desired package to install. foreach (keys %$media) { $i >= $media->{$_}{min} && $i <= $media->{$_}{max} and $medium = $_, last; } } $i >= $media->{$medium}{min} && $i <= $media->{$medium}{max} or die "unable to find right medium"; install_any::useMedium($medium); while ($i <= $media->{$medium}{max} && ($i < $min || scalar @transToInstall < $limitMinTrans)) { my $dep = $packages{packageName($depOrder->[$i++])} or next; if ($dep->[$MEDIUM]{selected}) { push @transToInstall, $dep; foreach (map { split '\|' } packageDepsId($dep)) { $min < $_ and $min = $_; } } else { log::l("ignoring package $dep->[$FILE] as its medium is not selected"); } --$nb; #- make sure the package is not taken into account as its medium is not selected. } } while ($nb > 0 && scalar(@transToInstall) == 0); #- avoid null transaction, it a nop that cost a bit. } #- added to exit typically after last media unselected. if ($nb == 0 && scalar(@transToInstall) == 0) { cleanHeaders($prefix); loopback::save_boot($loop_boot); return; } #- extract headers for parent as they are used by callback. extractHeaders($prefix, \@transToInstall, $media->{$medium}); if ($media->{$medium}{method} eq 'cdrom') { #- reset file descriptor open for main process but #- make sure error trying to change from hdlist are #- trown from main process too. install_any::getFile(packageFile($transToInstall[0]), $transToInstall[0][$MEDIUM]{descr}); } #- and make sure there are no staling open file descriptor too (before forking)! install_any::getFile('XXX'); my $retry; while ($retry || @transToInstall) { local (*INPUT, *OUTPUT); pipe INPUT, OUTPUT; if (my $pid = fork()) { close OUTPUT; my $error_msg = ''; local $_; while (<INPUT>) { if (/^die:(.*)/) { $error_msg = $1; last; } else { chomp; my @params = split ":"; if ($params[0] eq 'close') { &$callbackClose($params[1]); } else { installCallback(@params); } } } $error_msg and $error_msg .= join('', <INPUT>); waitpid $pid, 0; close INPUT; $error_msg and die $error_msg; } else { #- child process will run each transaction. $SIG{SEGV} = sub { log::l("segmentation fault on transactions"); c::_exit(0) }; my $db; eval { close INPUT; select((select(OUTPUT), $| = 1)[0]); $db = c::rpmdbOpen($prefix) or die "error opening RPM database: ", c::rpmErrorString(); my $trans = c::rpmtransCreateSet($db, $prefix); if ($retry) { log::l("opened rpm database for retry transaction of 1 package only"); c::rpmtransAddPackage($trans, $retry->[$HEADER], packageName($retry), $isUpgrade && allowedToUpgrade(packageName($retry))); } else { log::l("opened rpm database for transaction of ". scalar @transToInstall ." new packages, still $nb after that to do"); c::rpmtransAddPackage($trans, $_->[$HEADER], packageName($_), $isUpgrade && allowedToUpgrade(packageName($_))) foreach @transToInstall; } c::rpmdepOrder($trans) or die "error ordering package list: " . c::rpmErrorString(); c::rpmtransSetScriptFd($trans, fileno LOG); log::l("rpmRunTransactions start"); my @probs = c::rpmRunTransactions($trans, $callbackOpen, sub { #- callbackClose print OUTPUT "close:$_[0]\n"; }, sub { #- installCallback print OUTPUT join(":", @_), "\n"; }, 1); log::l("rpmRunTransactions done, now trying to close still opened fd"); install_any::getFile('XXX'); #- close still opened fd. if (@probs) { my %parts; @probs = reverse grep { if (s/(installing package) .* (needs (?:.*) on the (.*) filesystem)/$1 $2/) { $parts{$3} ? 0 : ($parts{$3} = 1); } else { 1; } } reverse map { s|/mnt||; $_ } @probs; c::rpmdbClose($db); die "installation of rpms failed:\n ", join("\n ", @probs); } }; $@ and print OUTPUT "die:$@\n"; c::rpmdbClose($db); log::l("rpm database closed"); close OUTPUT; #- now search for child process which may be locking the cdrom, making it unable to be ejected. my (@killpid, %tree, $pid); local (*DIR, *F, $_); opendir DIR, "/proc"; while ($pid = readdir DIR) { $pid =~ /^\d+$/ or next; open F, "/proc/$pid/status"; while (<F>) { /^Pid:\s+(\d+)/ and $pid == $1 || die "incorrect pid reported for $pid (found $1)"; if (/^PPid:\s+(\d+)/) { $tree{$pid} and die "PPID already found for $pid, previously $tree{$pid}, now $1"; $tree{$pid} = $1; } } close F; } closedir DIR; foreach (keys %tree) { #- remove child of this process (which will terminate). $pid = $_; while ($pid = $tree{$pid}) { $pid == $$ and push @killpid, $_ } #- remove child of 1 direct that have a pid greater than current one. $_ > $$ && $tree{$_} == 1 and push @killpid, $_; } if (@killpid) { log::l("killing process ". join(", ", @killpid)); kill 15, @killpid; sleep 2; kill 9, @killpid; } c::_exit(0); } #- if we are using a retry mode, this means we have to split the transaction with only #- one package for each real transaction. unless ($retry) { my @badPackages; foreach (@transToInstall) { if (!packageFlagInstalled($_) && $_->[$MEDIUM]{selected} && !exists($ignoreBadPkg{packageName($_)})) { push @badPackages, $_; log::l("bad package $_->[$FILE]"); } else { packageFreeHeader($_); } } @transToInstall = @badPackages; #- if we are in retry mode, we have to fetch only one package at a time. $retry = shift @transToInstall; } else { if (!packageFlagInstalled($retry) && $retry->[$MEDIUM]{selected} && !exists($ignoreBadPkg{packageName($retry)})) { log::l("bad package $retry->[$FILE] unable to be installed"); packageSetFlagSelected($retry, 0); cdie ("error installing package list: $retry->[$FILE]"); } packageFreeHeader($retry); $retry = shift @transToInstall; } } cleanHeaders($prefix); } while ($nb > 0 && !$pkgs::cancel_install); cleanHeaders($prefix); loopback::save_boot($loop_boot); } sub remove($$) { my ($prefix, $toRemove) = @_; return if $::g_auto_install || !@{$toRemove || []}; log::l("reading /usr/lib/rpm/rpmrc"); c::rpmReadConfigFiles() or die "can't read rpm config files"; log::l("\tdone"); my $db = c::rpmdbOpen($prefix) or die "error opening RPM database: ", c::rpmErrorString(); log::l("opened rpm database for removing old packages"); my $trans = c::rpmtransCreateSet($db, $prefix); foreach my $p (@$toRemove) { #- stuff remove all packages that matches $p, not a problem since $p has name-version-release format. c::rpmtransRemovePackages($db, $trans, $p) if allowedToUpgrade($p); } eval { fs::mount("/proc", "$prefix/proc", "proc", 0) } unless -e "$prefix/proc/cpuinfo"; my $callbackOpen = sub { log::l("trying to open file from $_[0] which should not happen"); }; my $callbackClose = sub { log::l("trying to close file from $_[0] which should not happen"); }; #- we are not checking depends since it should come when #- upgrading a system. although we may remove some functionalities ? #- do not modify/translate the message used with installCallback since #- these are keys during progressing installation, or change in other #- place (install_steps_gtk.pm,...). installCallback("Starting removing other packages", scalar @$toRemove); if (my @probs = c::rpmRunTransactions($trans, $callbackOpen, $callbackClose, \&installCallback, 1)) { die "removing of old rpms failed:\n ", join("\n ", @probs); } c::rpmtransFree($trans); c::rpmdbClose($db); log::l("rpm database closed"); #- keep in mind removing of these packages by cleaning $toRemove. @{$toRemove || []} = (); } sub selected_leaves { my ($packages) = @_; my %l; $l{$_->[$FILE]} = 1 foreach grep { packageFlagSelected($_) && !packageFlagBase($_) } @{$packages->{depslist}}; my %m = %l; foreach (@{$packages->{depslist}}) { delete $m{$_->[$FILE]} or next; foreach (map { split '\|' } grep { !/^NOTFOUND_/ } packageDepsId($_)) { delete $l{$packages->{depslist}[$_][$FILE]}; } } [ map { my @l; $l[$FILE] = $_; packageName(\@l); } grep { $l{$_} } keys %l ]; } sub naughtyServers { my ($packages) = @_; my @naughtyServers = qw(FreeWnn MySQL am-utils boa cfengine cups finger-server freeswan imap jabber leafnode lpr mon ntp apache openssh-server pidentd postfix postgresql-server proftpd rwall rwho telnet-server webmin wu-ftpd ypbind); # portmap nfs-utils-clients grep { my $p = packageByName($packages, $_); $p && packageFlagSelected($p); } @naughtyServers; } 1;