summaryrefslogtreecommitdiffstats
path: root/perl-install/diskdrake/hd_gtk.pm
blob: e6e0b667637316917ee3ce0cecdb4f79232ff274 (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
package diskdrake::hd_gtk; # $Id$

use diagnostics;
use strict;

use common;
use resize_fat::main;
use ugtk2 qw(:helpers :wrappers :create);
use partition_table qw(:types);
use partition_table::raw;
use detect_devices;
use diskdrake::interactive;
use run_program;
use loopback;
use devices;
use raid;
use any;
use log;
use fsedit;
use fs;

my ($width, $height, $minwidth) = (400, 50, 5);
my ($all_hds, $in, $do_force_reload, $current_kind, $current_entry, $update_all);
my ($w, @notebook, $done_button);

=begin


=head1 SYNOPSYS

struct {
  string name      # which is displayed in tab of the notebook
  bool no_auto     # wether the kind can disappear after creation
  string type      # one of { 'hd', 'raid', 'lvm', 'loopback', 'removable', 'nfs', 'smb' }
  hd | hd_lvm | part_raid[] | part_loopback[] | raw_hd[]  val

  # 
  widget main_box
  widget display_box
  widget action_box
  widget info_box
} current_kind

part current_entry

notebook current_kind[]

=cut

sub main {
    ($in, $all_hds, my $nowizard, $do_force_reload) = @_;

    @notebook = ();

    local $in->{grab} = 1;

    $w = ugtk2->new('DiskDrake');
    my $rc = "/usr/share/libDrakX/diskdrake.rc";
    -r $rc or $rc = dirname(__FILE__) . "/../diskdrake.rc";
    -r $rc or $rc = dirname(__FILE__) . "/../share/diskdrake.rc";
    Gtk2::Rc->parse($rc);

    # TODO
#    is_empty_array_ref($all_hds->{raids}) or raid::stopAll;
#    updateLoopback();

    gtkadd($w->{window},
	   gtkpack_(Gtk2::VBox->new(0,7),
		    0, filesystems_button_box(),
		    1, (my $notebook_widget = Gtk2::Notebook->new),
		    0, (my $per_kind_action_box = Gtk2::HBox->new(0,0)),
		    0, (my $general_action_box  = Gtk2::HBox->new(0,0)),
		   ),
	  );
    my $lock;
    $update_all = sub {
	$lock and return;
	$lock = 1;
	partition_table::assign_device_numbers($_) foreach fsedit::all_hds($all_hds);
	create_automatic_notebooks($notebook_widget);
	general_action_box($general_action_box, $nowizard);
	per_kind_action_box($per_kind_action_box, $current_kind);
	current_kind_changed($in, $current_kind);
	current_entry_changed($current_kind, $current_entry);
	$lock = 0;
    };
    create_automatic_notebooks($notebook_widget);

    $notebook_widget->signal_connect(switch_page => sub {
	$current_kind = $notebook[$_[2]];
	$current_entry = '';
	$update_all->();
    });
    $w->sync;
    $done_button->grab_focus;
    local $ugtk2::pop_it = 1;
    $in->ask_okcancel(N("Read carefully!"), N("Please make a backup of your data first"), 1) or return
      if $::isStandalone;
    $in->ask_warn('', 
N("If you plan to use aboot, be carefull to leave a free space (2048 sectors is enough)
at the beginning of the disk")) if arch() eq 'alpha' and !$::isEmbedded;

    $w->main;
}

sub try {
    my ($name, @args) = @_;
    my $f = $diskdrake::interactive::{$name} or die "unknown function $name";
    try_($name, \&{$f}, @args);
}
sub try_ {
    my ($name, $f, @args) = @_;

    fsedit::undo_prepare($all_hds) if $name ne 'Undo';

    my $v = eval { $f->($in, @args, $all_hds) };
    if (my $err = $@) {
	$in->ask_warn(N("Error"), formatError($err));
    }
    if ($v eq 'force_reload') {	
	$all_hds = $do_force_reload->();
    }

    $current_entry = '' if !diskdrake::interactive::is_part_existing($current_entry, $all_hds);
    $update_all->();

    if ($v && member($name, 'Done', 'Wizard')) {
	$::isEmbedded ? kill('USR1', $::CCPID) : Gtk2->main_quit; 
    }
}

################################################################################
# generic: helpers
################################################################################
sub add_kind2notebook {
    my ($notebook_widget, $kind) = @_;
    die if $kind->{main_box};

    $kind->{display_box} = gtkset_size_request(Gtk2::HBox->new(0,0), $width, $height);
    $kind->{action_box} = gtkset_size_request(Gtk2::VBox->new(0,0), 150, 180);
    $kind->{info_box} = Gtk2::VBox->new(0,0);
    $kind->{main_box} =
      gtkpack_(Gtk2::VBox->new(0,7),
	       0, $kind->{display_box},
	       1, gtkpack_(Gtk2::HBox->new(0,7),
			   0, $kind->{action_box},
			   1, $kind->{info_box}));
    ugtk2::add2notebook($notebook_widget, $kind->{name}, $kind->{main_box});
    push @notebook, $kind;
    $kind;
}

sub general_action_box {
    my ($box, $nowizard) = @_;
    $_->widget->destroy foreach $box->children;
    my @actions = (if_($::isInstall && !$nowizard, N_("Wizard")), 
		   diskdrake::interactive::general_possible_actions($in, $all_hds), 
		   N_("Done"));
    foreach my $s (@actions) {
	my $button = Gtk2::Button->new(translate($s));
	$done_button = $button if $s eq 'Done';
	gtkadd($box, gtksignal_connect($button, clicked => sub { try($s) }));
    }
}
sub per_kind_action_box {
    my ($box, $kind) = @_;
    $_->widget->destroy foreach $box->children;

    $kind->{type} =~ /hd|lvm/ or return;

    foreach my $s (diskdrake::interactive::hd_possible_actions($in, kind2hd($kind), $all_hds)) {
	gtkadd($box, 
	       gtksignal_connect(Gtk2::Button->new(translate($s)),
				 clicked => sub { try($s, kind2hd($kind)) }));
    }
}
sub per_entry_action_box {
    my ($box, $kind, $entry) = @_;
    $_->widget->destroy foreach $box->children;

    if ($entry) {
	my @buttons = map { 
	    my $s = $_;
	    my $w = Gtk2::Button->new(translate($s));
	    $w->signal_connect(clicked => sub { try($s, kind2hd($kind), $entry) });
	    $w;
	} diskdrake::interactive::part_possible_actions($in, kind2hd($kind), $entry, $all_hds);

	gtkadd($box, gtkadd(Gtk2::Frame->new(N("Choose action")),
			    create_scrolled_window(gtkpack__(Gtk2::VBox->new(0,0), @buttons)))) if @buttons;
    } else {
	my $txt = !$::isStandalone && fsedit::is_one_big_fat($all_hds->{hds}) ?
N("You have one big FAT partition
(generally used by MicroSoft Dos/Windows).
I suggest you first resize that partition
(click on it, then click on \"Resize\")") : N("Please click on a partition");
	gtkpack($box, gtktext_insert(Gtk2::TextView->new, $txt));
    }
}

sub per_entry_info_box {
    my ($box, $kind, $entry) = @_;
    $_->widget->destroy foreach $box->children;
    my $info;
    if ($entry) {
	$info = diskdrake::interactive::format_part_info(kind2hd($kind), $entry);
    } elsif ($kind->{type} =~ /hd|lvm/) {
	$info = diskdrake::interactive::format_hd_info($kind->{val});
    }
    gtkpack($box, gtkadd(Gtk2::Frame->new(N("Details")), gtkset_justify(Gtk2::Label->new($info), 'left')));
}

sub current_kind_changed {
    my ($_in, $kind) = @_;

    $_->widget->destroy foreach $kind->{display_box}->children;

    my $v = $kind->{val};
    my @parts = 
      $kind->{type} eq 'raid' ? grep { $_ } @$v :
      $kind->{type} eq 'loopback' ? @$v : fsedit::get_fstab_and_holes($v);
    my $totalsectors = 
      $kind->{type} =~ /raid|loopback/ ? sum(map { $_->{size} } @parts) : $v->{totalsectors};
    create_buttons4partitions($kind, $totalsectors, @parts);
}

sub current_entry_changed {
    my ($kind, $entry) = @_;
    $current_entry = $entry;
    if ($kind) {
	per_entry_action_box($kind->{action_box}, $kind, $entry);
	per_entry_info_box($kind->{info_box}, $kind, $entry);
    }
}

sub create_automatic_notebooks {
    my ($notebook_widget) = @_;

    $_->{marked} = 0 foreach @notebook;
    my $may_add = sub {
	my ($kind) = @_;
	my @l = grep { $kind->{val} == $_->{val} } @notebook;
	@l > 1 and log::l("weird: create_automatic_notebooks");
	$kind = $l[0] || add_kind2notebook($notebook_widget, $kind);
	$kind->{marked} = 1;
    };
    $may_add->(hd2kind($_)) foreach @{$all_hds->{hds}};
    $may_add->(lvm2kind($_)) foreach @{$all_hds->{lvms}};
    $may_add->(raid2kind()) if any { $_ } @{$all_hds->{raids}};
    $may_add->(loopback2kind()) if @{$all_hds->{loopbacks}};

    @notebook = grep_index {
	my $b = $_->{marked} or $notebook_widget->remove_page($::i);
	$b;
    } @notebook;
    @notebook or die N("No hard drives found");
}

################################################################################
# parts: helpers
################################################################################
sub create_buttons4partitions {
    my ($kind, $totalsectors, @parts) = @_;

    $width = max($width, 0.9 * second($w->{window}->window->get_size)) if $w->{window}->window;

    my $ratio = $totalsectors ? ($width - @parts * $minwidth) / $totalsectors : 1;
    while (1) {
	my $totalwidth = sum(map { $_->{size} * $ratio + $minwidth } @parts);
	$totalwidth <= $width and last;
	$ratio /= $totalwidth / $width * 1.1;
    }

    foreach my $entry (@parts) {
	my $w = Gtk2::Button->new($entry->{mntpoint} || '') or die '';
	$w->signal_connect(focus_in_event     => sub { current_entry_changed($kind, $entry) });
	$w->signal_connect(button_press_event => sub { current_entry_changed($kind, $entry) });
	$w->signal_connect(key_press_event => sub {
	    my (undef, $event) = @_;
	    member('control-mask', @{$event->state}) or return; 
	    my $c = chr $event->keyval;

	    foreach my $s (diskdrake::interactive::part_possible_actions($in, kind2hd($kind), $entry, $all_hds)) {
		${{
		    Create => 'c', Delete => 'd', Format => 'f', 
		    Loopback => 'l', Resize => 'r', Type => 't', 
		    Mount => 'M', Unmount => 'u', 'Mount point' => 'm',
		    'Add to LVM' => 'L', 'Remove from LVM' => 'L', 
		    'Add to RAID' => 'R', 'Remove from RAID' => 'R',
		}}{$s} eq $c or next;

		try($s, kind2hd($kind), $entry);
		last;
	    }
	});
	$w->set_name("PART_" . type2name($entry->{type}));
	$w->set_size_request($entry->{size} * $ratio + $minwidth, 0);
	gtkpack__($kind->{display_box}, $w);
	$w->grab_focus if $current_entry && fsedit::is_same_part($current_entry, $entry);
    }
}


################################################################################
# disks: helpers
################################################################################
sub current_hd { 
    $current_kind->{type} eq 'hd' or die 'current_hd called but $current_kind is not an hd';
    $current_kind->{val};
}
sub current_part {
    current_hd();
    $current_entry;
}

sub kind2hd {
    my ($kind) = @_;
    $kind->{type} =~ /hd|lvm/ ? $kind->{val} : {}
}

sub hd2kind {
    my ($hd) = @_;
    { type => 'hd', name => $hd->{device}, val => $hd };
}

sub filesystems_button_box() {
    my @types = (N_("Ext2"), N_("Journalised FS"), N_("Swap"), arch() =~ /sparc/ ? N_("SunOS") : arch() eq "ppc" ? N_("HFS") : N_("FAT"),
		 N_("Other"), N_("Empty"));
    my %name2type = (Ext2 => 0x83, 'Journalised FS' => 0x483, Swap => 0x82, Other => 1, FAT => 0xb, HFS => 0x402);

    gtkpack(Gtk2::HBox->new(0,0), 
	    N("Filesystem types:"),
	    map { my $w = Gtk2::Button->new(translate($_));
		  my $t = $name2type{$_};
		  $w->signal_connect(clicked => sub { try_('', \&createOrChangeType, $t, current_hd(), current_part()) });
		  $w->can_focus(0);
		  $w->set_name($_); 
		  $w;
	    } @types);
}

sub createOrChangeType {
    my ($in, $type, $hd, $part, $all_hds) = @_;

    $part ||= !fsedit::get_fstab($hd) && 
              { type => 0, start => 1, size => $hd->{totalsectors} - 1 };
    $part or return;
    if ($type == 1) {
	$in->ask_warn('', N("Use ``%s'' instead", $part->{type} ? N("Type") : N("Create")));
    } elsif (!$type) {
	$in->ask_warn('', N("Use ``%s'' instead", N("Delete"))) if $part->{type};
    } elsif ($part->{type}) {
	return if $type == $part->{type};
	$in->ask_warn('', isBusy($part) ? N("Use ``Unmount'' first") : N("Use ``%s'' instead", N("Type")));
    } else {
	$part->{type} = $type;
	diskdrake::interactive::Create($in, $hd, $part, $all_hds);
    }
}

################################################################################
# lvms: helpers
################################################################################
sub lvm2kind {
    my ($lvm) = @_;
    { type => 'lvm', name => $lvm->{VG_name}, val => $lvm };
}

################################################################################
# raids: helpers
################################################################################
sub raid2kind {
    { type => 'raid', name => 'raid', val => $all_hds->{raids} };
}

################################################################################
# loopbacks: helpers
################################################################################
sub loopback2kind {
    { type => 'loopback', name => 'loopback', val => $all_hds->{loopbacks} };
}

1;
an>) or return; #- check for medium selection, if the medium has not been #- selected, the package cannot be selected. foreach (values %{$packages->{mediums}}) { !$_->{selected} && $pkg->id >= $_->{start} && $pkg->id <= $_->{end} and return; } return { $pkg->id => 1 }; } sub packageCallbackChoices { my ($urpm, $_db, $state, $choices) = @_; if (my $prefer = find { $_->arch ne 'src' && exists $preferred{$_->name} } @$choices) { $prefer; } else { my @l = grep { #- or if a kernel has to be chosen, chose the basic one. $_->arch ne 'src' && $_->name =~ /kernel-\d/ and return $_; #- or even if a package requires a specific locales which #- is already selected. find { /locales-/ && do { my $p = packageByName($urpm, $_); $p && $p->flag_available; }; } $_->requires_nosense; } @$choices; if (!@l) { push @l, $choices->[0]; log::l("packageCallbackChoices: default choice from ", join(",", map { $urpm->{depslist}[$_]->name } keys %{$state->{selected}}), " in ", join(",", map { $_->name } @$choices)); } #-log::l("packageCallbackChoices: chosen " . join(" ", map { $_->name } @l)); @l; } } #- selection, unselection of package. sub selectPackage { my ($packages, $pkg, $b_base, $o_otherOnly) = @_; #- select package and dependancies, o_otherOnly may be a reference #- to a hash to indicate package that will strictly be selected #- when value is true, may be selected when value is false (this #- is only used for unselection, not selection) my $state = $packages->{state} ||= {}; my @l = $packages->resolve_requested($packages->{rpmdb}, $state, packageRequest($packages, $pkg) || {}, callback_choices => \&packageCallbackChoices); if ($b_base || $o_otherOnly) { foreach (@l) { $b_base and $_->set_flag_base; $o_otherOnly and $o_otherOnly->{$_->id} = $_->flag_requested; } $o_otherOnly and $packages->disable_selected($packages->{rpmdb}, $state, @l); } 1; } sub unselectPackage($$;$) { my ($packages, $pkg, $o_otherOnly) = @_; #- base package are not unselectable, #- and already unselected package are no more unselectable. $pkg->flag_base and return; $pkg->flag_selected or return; my $state = $packages->{state} ||= {}; log::l("removing selection on package ".$pkg->fullname); my @l = $packages->disable_selected($packages->{rpmdb}, $state, $pkg); log::l(" removed selection on package " . $pkg->fullname . "gives " . join(',', map { scalar $_->fullname } @l)); if ($o_otherOnly) { foreach (@l) { $o_otherOnly->{$_->id} = undef; } log::l(" reselecting removed selection..."); $packages->resolve_requested($packages->{rpmdb}, $state, $o_otherOnly, callback_choices => \&packageCallbackChoices); log::l(" done"); } 1; } sub togglePackageSelection($$;$) { my ($packages, $pkg, $o_otherOnly) = @_; $pkg->flag_selected ? unselectPackage($packages, $pkg, $o_otherOnly) : selectPackage($packages, $pkg, 0, $o_otherOnly); } sub setPackageSelection($$$) { my ($packages, $pkg, $value) = @_; $value ? selectPackage($packages, $pkg) : unselectPackage($packages, $pkg); } sub unselectAllPackages($) { my ($packages) = @_; my %keep_selected; log::l("unselecting all packages..."); foreach (@{$packages->{depslist}}) { if ($_->flag_base || $_->flag_installed && $_->flag_selected) { #- keep track of package that should be kept selected. $keep_selected{$_->id} = $_; log::l("...keeping ".$_->fullname); } else { #- deselect all packages except base or packages that need to be upgraded. $_->set_flag_required(0); $_->set_flag_requested(0); } } #- clean staten, in order to start with a brand new set... $packages->{state} = {}; $packages->resolve_requested($packages->{rpmdb}, $packages->{state}, \%keep_selected, callback_choices => \&packageCallbackChoices); } sub psUpdateHdlistsDeps { my ($prefix, $_method, $packages) = @_; my $need_copy = 0; #- check if current configuration is still up-to-date and do not need to be updated. foreach (values %{$packages->{mediums}}) { $_->{selected} || $_->{ignored} or next; my $urpmidir = -w "$prefix/var/lib/urpmi" ? "$prefix/var/lib/urpmi" : "/tmp"; my $hdlistf = "$urpmidir/hdlist.$_->{fakemedium}.cz" . ($_->{hdlist} =~ /\.cz2/ && "2"); my $synthesisf = "$urpmidir/synthesis.hdlist.$_->{fakemedium}.cz" . ($_->{hdlist} =~ /\.cz2/ && "2"); if (-s $hdlistf != $_->{hdlist_size}) { install_any::getAndSaveFile("Mandrake/base/$_->{hdlist}", $hdlistf) or die "no $_->{hdlist} found"; symlinkf $hdlistf, "/tmp/$_->{hdlist}"; ++$need_copy; } if (-s $synthesisf != $_->{synthesis_hdlist_size}) { install_any::getAndSaveFile("Mandrake/base/synthesis.$_->{hdlist}", $synthesisf); -s $synthesisf > 0 or unlink $synthesisf; } } if ($need_copy) { #- this is necessary for urpmi. my $urpmidir = -w "$prefix/var/lib/urpmi" ? "$prefix/var/lib/urpmi" : "/tmp"; install_any::getAndSaveFile("Mandrake/base/$_", "$urpmidir/$_") foreach qw(rpmsrate); } } sub psUsingHdlists { my ($prefix, $method) = @_; my $listf = install_any::getFile('Mandrake/base/hdlists') or die "no hdlists found"; my $packages = new URPM; #- add additional fields used by DrakX. @$packages{qw(count mediums)} = (0, {}); #- parse hdlists file. my $medium = 1; foreach (<$listf>) { chomp; s/\s*#.*$//; /^\s*$/ and next; m/^\s*(noauto:)?(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, $2, $medium, $3, $4, !$1); ++$medium; } log::l("psUsingHdlists read " . int(@{$packages->{depslist}}) . " headers on " . int(keys %{$packages->{mediums}}) . " hdlists"); $packages; } sub psUsingHdlist { my ($prefix, $method, $packages, $hdlist, $medium, $rpmsdir, $descr, $selected, $o_fhdlist) = @_; my $fakemedium = "$descr ($method$medium)"; my $urpmidir = -w "$prefix/var/lib/urpmi" ? "$prefix/var/lib/urpmi" : "/tmp"; log::l("trying to read $hdlist for medium $medium"); #- if the medium already exist, use it. $packages->{mediums}{$medium} and return $packages->{mediums}{$medium}; my $m = { hdlist => $hdlist, method => $method, medium => $medium, rpmsdir => $rpmsdir, #- where is RPMS directory. descr => $descr, fakemedium => $fakemedium, selected => $selected, #- default value is only CD1, it is really the minimal. ignored => !$selected, #- keep track of ignored medium by DrakX. pubkey => [], #- all pubkey block here }; #- copy hdlist file directly to urpmi directory, this will be used #- for getting header of package during installation or after by urpmi. my $newf = "$urpmidir/hdlist.$fakemedium.cz" . ($hdlist =~ /\.cz2/ && "2"); -e $newf and do { unlink $newf or die "cannot remove $newf: $!" }; install_any::getAndSaveFile($o_fhdlist || "Mandrake/base/$hdlist", $newf) or do { unlink $newf; die "no $hdlist found" }; $m->{hdlist_size} = -s $newf; #- keep track of size for post-check. symlinkf $newf, "/tmp/$hdlist"; #- if $o_fhdlist is defined, this is preferable not to try to find the associated synthesis. my $newsf = "$urpmidir/synthesis.hdlist.$fakemedium.cz" . ($hdlist =~ /\.cz2/ && "2"); unless ($o_fhdlist) { #- copy existing synthesis file too. install_any::getAndSaveFile("Mandrake/base/synthesis.$hdlist", $newsf); $m->{synthesis_hdlist_size} = -s $newsf; #- keep track of size for post-check. -s $newsf > 0 or unlink $newsf; } #- get all keys corresponding in the right pubkey file, #- they will be added in rpmdb later if not found. my $pubkey = install_any::getFile("Mandrake/base/pubkey" . ($hdlist =~ /hdlist(\S*)\.cz2?/ && $1)); $m->{pubkey} = [ $packages->parse_armored_file($pubkey) ]; #- integrate medium in media list, only here to avoid download error (update) to be propagated. $packages->{mediums}{$medium} = $m; #- avoid using more than one medium if Cd is not ejectable. #- but keep all medium here so that urpmi has the whole set. $m->{ignored} ||= $method eq 'cdrom' && $medium > 1 && !common::usingRamdisk(); #- parse synthesis (if available) of directly hdlist (with packing). if ($m->{ignored}) { log::l("ignoring packages in $hdlist"); } else { if (-s $newsf) { ($m->{start}, $m->{end}) = $packages->parse_synthesis($newsf); } elsif (-s $newf) { ($m->{start}, $m->{end}) = $packages->parse_hdlist($newf, 1); } else { delete $packages->{mediums}{$medium}; unlink $newf; $o_fhdlist or unlink $newsf; die "fatal: no hdlist nor synthesis to read for $fakemedium"; } $m->{start} > $m->{end} and do { delete $packages->{mediums}{$medium}; unlink $newf; $o_fhdlist or unlink $newsf; die "fatal: nothing read in hdlist or synthesis for $fakemedium" }; log::l("read " . ($m->{end} - $m->{start} + 1) . " packages in $hdlist"); } $m; } sub read_rpmsrate { my ($packages, $f) = @_; my $line_nb = 0; my $fatal_error; my (@l); local $_; 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[-1][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 = find { /^\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 { if_(/locales-(.*)/, qq(LOCALES"$1")) } $p->requires_nosense; my @m3 = ((grep { !/^\d$/ } @m), @m2); if (member('INSTALL', @m3)) { member('NOCOPY', @m3) or push @{$packages->{needToCopy} ||= []}, $_; next; #- don't need to put INSTALL flag for a package. } if ($p->rate) { my @m4 = $p->rflags; if (@m3 > 1 || @m4 > 1) { log::l("can't handle complicate flags for packages appearing twice ($_)"); $fatal_error++; } log::l("package $_ appearing twice with different rates ($rate != ".$p->rate.")") if $rate != $p->rate; $p->set_rate($rate); $p->set_rflags("$m3[0]||$m4[0]"); } else { $p->set_rate($rate); $p->set_rflags(@m3); } } else { print "$_ = ", join(" && ", @m), "\n"; } } push @l, @l2; } else { push @l, [ $l2[0][0], $l2[-1][1] ]; } } $fatal_error and die "$fatal_error fatal errors in rpmsrate"; } 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, $selected); /^(.*?)\s*\[path=(.*?)\](.*)/ and $_ = "$1$3", $path = $2; /^(.*?)\s*\[icon=(.*?)\](.*)/ and $_ = "$1$3", $icon = $2; /^(.*?)\s*\[descr=(.*?)\](.*)/ and $_ = "$1$3", $descr = $2; /^(.*?)\s*\[selected=(.*?)\](.*)/ and $_ = "$1$3", $selected = $2; $compssUsers{"$path|$_"} = { label => $_, verbatim => $verbatim, path => $path, icons => $icon, descr => $descr, if_(defined $selected, selected => [ split /[\s,]+/, $selected ]), 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 (@{$packages->{depslist}}) { my @flags = $p->rflags; if ($p->rate && any { any { !/^!/ && $fl{$_} } split('\|\|') } @flags) { $flat .= sprintf "\t%d %s\n", $p->rate, $p->name; } } } my $urpmidir = -w "$prefix/var/lib/urpmi" ? "$prefix/var/lib/urpmi" : "/tmp"; output "$urpmidir/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 { $b->rate <=> $a->rate } @{$packages->{depslist}}) { my @flags = $p->rflags; next if !$p->rate || $p->rate < $min_level || any { !any { /^!(.*)/ ? !$compssUsersChoice->{$1} : $compssUsersChoice->{$_} } split('\|\|') } @flags; #- determine the packages that will be selected when #- selecting $p. the packages are not selected. my $state = $packages->{state} ||= {}; my @l = $packages->resolve_requested($packages->{rpmdb}, $state, packageRequest($packages, $p) || {}, callback_choices => \&packageCallbackChoices); #- this enable an incremental total size. my $old_nb = $nb; foreach (@l) { $nb += $_->size; } if ($max_size && $nb > $max_size) { $nb = $old_nb; $min_level = $p->rate; $packages->disable_selected($packages->{rpmdb}, $state, @l); last; } } log::l("setSelectedFromCompssList: reached size ", formatXiB($nb), ", up to indice $min_level (less than ", formatXiB($max_size), ")"); log::l("setSelectedFromCompssList: ", join(" ", sort map { $_->name } grep { $_->flag_selected } @{$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 $state = delete $packages->{state}; my @l = @{$packages->{depslist}}; my @flags = map { ($_->flag_requested && 1) + ($_->flag_required && 2) + ($_->flag_upgrade && 4) } @l; [ $packages, $state, \@l, \@flags ]; } sub restoreSelected { my ($packages, $state, $l, $flags) = @{$_[0]}; $packages->{state} = $state; mapn { my ($pkg, $flag) = @_; $pkg->set_flag_requested($flag & 1); $pkg->set_flag_required($flag & 2); $pkg->set_flag_upgrade($flag & 4); } $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 & CHARSET, too costly grep { !/LOCALES|CHARSET/ } @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, $slowpart_counter); foreach my $p (@{$packages->{depslist}}) { my @flags = $p->rflags; next if !$p->rate || $p->rate < $min_level; my $flags = join("\t", @flags = or_ify(@flags)); $group{$p->name} = ($memo{$flags} ||= or_clean(@flags)); #- determine the packages that will be selected when selecting $p. #- make a fast selection (but potentially erroneous). #- installed and upgrade flags must have been computed (see compute_installed_flags). my %newSelection; unless ($p->flag_available) { my @l2 = $p->id; my $id; while (defined($id = shift @l2)) { exists $newSelection{$id} and next; $newSelection{$id} = undef; my $pkg = $packages->{depslist}[$id]; foreach ($pkg->requires_nosense) { my @choices = keys %{$packages->{provides}{$_} || {}}; if (@choices <= 1) { push @l2, @choices; } elsif (! find { exists $newSelection{$_} } @choices) { my ($candidate_id, $prefer_id); foreach (@choices) { ++$slowpart_counter; my $ppkg = $packages->{depslist}[$_] or next; $ppkg->flag_available and $prefer_id = $candidate_id = undef, last; exists $preferred{$ppkg->name} and $prefer_id = $_; $ppkg->name =~ /kernel-\d/ and $prefer_id ||= $_; foreach my $l ($ppkg->requires_nosense) { /locales-/ or next; my $pppkg = packageByName($packages, $l) or next; $pppkg->flag_available and $prefer_id ||= $_; } $candidate_id = $_; } if (defined $prefer_id || defined $candidate_id) { push @l2, defined $prefer_id ? $prefer_id : $candidate_id; } } } } } foreach (keys %newSelection) { my $p = $packages->{depslist}[$_] or next; my $s = $group{$p->name} || do { join("\t", or_ify($p->rflags)); }; next if length($s) > 120; # HACK, truncated too complicated expressions, too costly my $m = "$flags\t$s"; $group{$p->name} = ($memo{$m} ||= or_clean(@flags, split("\t", $s))); } } my (%sizes, %pkgs); while (my ($k, $v) = each %group) { my $pkg = packageByName($packages, $k) or next; push @{$pkgs{$v}}, $k; $sizes{$v} += $pkg->size - $packages->{sizes}{$pkg->name}; } log::l(sprintf "%s %dMB %s", $_, $sizes{$_} / sqr(1024), join(',', @{$pkgs{$_}})) foreach keys %sizes; \%sizes, \%pkgs; } sub openInstallLog { my ($prefix) = @_; my $f = "$prefix/root/drakx/install.log"; open(my $LOG, ">> $f") ? log::l("opened $f") : log::l("Failed to open $f. No install log will be kept."); #-# CORE::select((CORE::select($LOG), $| = 1)[0]); c::rpmErrorSetCallback(fileno $LOG); #- c::rpmSetVeryVerbose(); $LOG; } sub rpmDbOpen { my ($prefix, $o_rebuild_needed) = @_; if ($o_rebuild_needed) { 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"), rm_rf($rebuilddb_dir); URPM::DB::rebuild($prefix) or log::l("rebuilding of rpm database failed: " . c::rpmErrorString()), c::_exit(2); c::_exit(0); } } my $db; if ($db = URPM::DB::open($prefix)) { log::l("opened rpm database for examining existing packages"); } else { log::l("unable to open rpm database, using empty rpm db emulation"); $db = new URPM; } $db; } sub rpmDbOpenForInstall { my ($prefix) = @_; #- there is a bug in rpm 4.2 where all operations for accessing rpmdb files are not #- always done using prefix, we need to setup a symlink in /var/lib/rpm for that ... unless (-e "/var/lib/rpm") { #- check if at some time a /var/lib directory has been made. if (-d "/var/lib") { symlinkf "$prefix/var/lib/rpm", "/var/lib/rpm"; } else { symlinkf "$prefix/var/lib", "/var/lib"; } } my $db = URPM::DB::open($prefix, 1); $db and log::l("opened rpmdb for writing in $prefix"); $db; } sub cleanOldRpmDb { 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 $_"); rm_rf("$prefix/var/lib/rpm/$_"); } } } sub selectPackagesAlreadyInstalled { my ($packages, $_prefix) = @_; log::l("computing installed flags and size of installed packages"); $packages->{sizes} = $packages->compute_installed_flags($packages->{rpmdb}); } sub selectPackagesToUpgrade { my ($packages, $_prefix, $o_medium) = @_; #- check before that if medium is given, it should be valid. $o_medium && (! defined $o_medium->{start} || ! defined $o_medium->{end}) and return; log::l("selecting packages to upgrade"); my $state = $packages->{state} ||= {}; $state->{selected} = {}; my %selection; $packages->request_packages_to_upgrade($packages->{rpmdb}, $state, \%selection, requested => undef, $o_medium ? (start => $o_medium->{start}, end => $o_medium->{end}) : (), ); log::l("resolving dependencies..."); $packages->resolve_requested($packages->{rpmdb}, $state, \%selection, callback_choices => \&packageCallbackChoices); log::l("...done"); } sub allowedToUpgrade { $_[0] !~ /^(kernel|kernel22|kernel2.2|kernel-secure|kernel-smp|kernel-linus|kernel-linus2.2|hackkernel|kernel-enterprise)$/ } sub installTransactionClosure { my ($packages, $id2pkg) = @_; my ($id, %closure, @l, $medium, $min_id, $max_id); @l = sort { $a <=> $b } keys %$id2pkg; #- search first usable medium (sorted by medium ordering). foreach (sort { $a->{start} <=> $b->{start} } values %{$packages->{mediums}}) { unless ($_->{selected}) { #- this medium is not selected, but we have to make sure no package are left #- in $id2pkg. if (defined $_->{start} && defined $_->{end}) { foreach ($_->{start} .. $_->{end}) { delete $id2pkg->{$_}; } } #- anyway, examine the next one. next; } if ($l[0] <= $_->{end}) { #- we have a candidate medium, it could be the right one containing #- the first package of @l... $l[0] >= $_->{start} and $medium = $_, last; #- ... but it could be necessary to find the first #- medium containing package of @l. foreach my $id (@l) { $id >= $_->{start} && $id <= $_->{end} and $medium = $_, last; } $medium and last; } } $medium or return (); #- no more medium usable -> end of installation by returning empty list. ($min_id, $max_id) = ($medium->{start}, $medium->{end}); #- it is sure at least one package will be installed according to medium chosen. install_any::useMedium($medium->{medium}); if ($medium->{method} eq 'cdrom') { my $pkg = $packages->{depslist}[$l[0]]; #- force changeCD callback to be called from main process. install_any::getFile($pkg->filename, $medium->{descr}); #- close opened handle above. install_any::getFile('XXX'); } while (defined($id = shift @l)) { my @l2 = $id; while (defined($id = shift @l2)) { exists $closure{$id} and next; $id >= $min_id && $id <= $max_id or next; $closure{$id} = undef; my $pkg = $packages->{depslist}[$id]; foreach ($pkg->requires_nosense) { foreach (keys %{$packages->{provides}{$_} || {}}) { if ($id2pkg->{$_}) { push @l2, $_; last; } } } } keys %closure >= $limitMinTrans and last; } map { delete $id2pkg->{$_} } grep { $id2pkg->{$_} } sort { $a <=> $b } keys %closure; } sub installCallback { # my $msg = shift; # log::l($msg .": ". join(',', @_)); } sub install($$$;$$) { my ($prefix, $isUpgrade, $toInstall, $packages) = @_; my %packages; delete $packages->{rpmdb}; #- make sure rpmdb is closed before. return if $::g_auto_install || !scalar(@$toInstall); #- for root loopback'ed /boot my $loop_boot = loopback::prepare_boot(); #- 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{$pkg->id} = $pkg; $nb++; $total += to_int($pkg->size); #- do not correct for upgrade! } log::l("pkgs::install $prefix"); log::l("pkgs::install the following: ", join(" ", map { $_->name } values %packages)); eval { fs::mount("/proc", "$prefix/proc", "proc", 0) } unless -e "$prefix/proc/cpuinfo"; URPM::read_config_files(); my $LOG = openInstallLog($prefix); #- 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($packages, 'user', undef, 'install', $nb, $total); do { my @transToInstall = installTransactionClosure($packages, \%packages); $nb = values %packages; #- 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, $packages->{mediums}); my ($retry_pkg, $retry_count); while ($retry_pkg || @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') { my $pkg = $packages->{depslist}[$params[1]]; #- update flag associated to package. $pkg->set_flag_installed(1); $pkg->set_flag_upgrade(0); #- update obsoleted entry. foreach (keys %{$packages->{state}{rejected}}) { if (exists $packages->{state}{rejected}{$_}{closure}{$pkg->fullname}) { delete $packages->{state}{rejected}{$_}{closure}{$pkg->fullname}; %{$packages->{state}{rejected}{$_}{closure}} or delete $packages->{state}{rejected}{$_}; } } } else { installCallback($packages, @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 @prev_pids = grep { /^\d+$/ } all("/proc"); close INPUT; select((select(OUTPUT), $| = 1)[0]); if ($::testing) { my $size_typical = $nb ? int($total/$nb) : 0; foreach (@transToInstall) { log::l("i would install ", $_->name, " now"); my $id = $_->id; print OUTPUT "inst:$id:start:0:$size_typical\ninst:$id:progress:0:$size_typical\nclose:$id\n"; } } else { eval { my $db = rpmDbOpenForInstall($prefix) or die "error opening RPM database: ", c::rpmErrorString(); my $trans = $db->create_transaction($prefix); if ($retry_pkg) { log::l("opened rpm database for retry transaction of 1 package only"); $trans->add($retry_pkg, $isUpgrade && allowedToUpgrade($retry_pkg->name)); } else { log::l("opened rpm database for transaction of " . int(@transToInstall) . " new packages, still $nb after that to do"); $trans->add($_, $isUpgrade && allowedToUpgrade($_->name)) foreach @transToInstall; } my @checks = $trans->check; @checks and log::l("check failed : ".join("\n ", @checks)); $trans->order or die "error ordering package list: " . c::rpmErrorString(); $trans->set_script_fd(fileno $LOG); log::l("rpm transactions start"); my $fd; #- since we return the "fileno", perl doesn't know we're still using it, and so closes it, and :-( my @probs = $trans->run($packages, force => 1, nosize => 1, callback_open => sub { my ($data, $_type, $id) = @_; my $pkg = defined $id && $data->{depslist}[$id]; my $medium = packageMedium($packages, $pkg); my $f = $pkg && $pkg->filename; print $LOG "$f\n"; $fd = install_any::getFile($f, $medium->{descr}); $fd ? fileno $fd : -1; }, callback_close => sub { my ($data, $_type, $id) = @_; my $pkg = defined $id && $data->{depslist}[$id] or return; my $check_installed; $db->traverse_tag('name', [ $pkg->name ], sub { my ($p) = @_; $check_installed ||= $pkg->compare_pkg($p) == 0; }); $check_installed and print OUTPUT "close:$id\n"; }, callback_inst => sub { my ($_data, $type, $id, $subtype, $amount, $total) = @_; print OUTPUT "$type:$id:$subtype:$amount:$total\n"; }); log::l("transactions done, now trying to close still opened fd"); install_any::getFile('XXX'); #- close still opened fd. @probs and die "installation of rpms failed:\n ", join("\n ", @probs); }; $@ and print OUTPUT "die:$@\n" } close OUTPUT; #- now search for child process which may be locking the cdrom, making it unable to be ejected. my @allpids = grep { /^\d+$/ } all("/proc"); my %ppids; foreach (@allpids) { push @{$ppids{$1 || 1}}, $_ if cat_("/proc/$_/status") =~ /^PPid:\s+(\d+)/m; } my @killpid = difference2(\@allpids, [ @prev_pids, difference2([ $$, hashtree2list(getppid(), \%ppids) ], [ hashtree2list($$, \%ppids) ]) ]); if (@killpid) { foreach (@killpid) { my ($prog, @para) = split("\0", cat_("/proc/$_/cmdline")); log::l("ERROR: DrakX should not have to clean the packages shit. Killing $_: " . join(' ', $prog, @para) . ".") if $prog ne '/usr/lib/gconfd-2'; } 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. if (!$retry_pkg) { my @badPackages; foreach (@transToInstall) { if (!$_->flag_installed && packageMedium($packages, $_)->{selected} && !exists($ignoreBadPkg{$_->name})) { push @badPackages, $_; log::l("bad package ".$_->fullname); } else { $_->free_header; } } @transToInstall = @badPackages; #- if we are in retry mode, we have to fetch only one package at a time. $retry_pkg = shift @transToInstall; $retry_count = 3; } else { my $name; if (!$retry_pkg->flag_installed && packageMedium($packages, $retry_pkg)->{selected} && !exists($ignoreBadPkg{$retry_pkg->name})) { if ($retry_count) { log::l("retrying installing package ".$retry_pkg->fullname." alone in a transaction"); --$retry_count; } else { log::l("bad package " . $retry_pkg->fullname . " unable to be installed"); $retry_pkg->set_flag_requested(0); $retry_pkg->set_flag_required(0); #- keep name to display (problem of displaying ?). $name = $retry_pkg->fullname; $retry_pkg->free_header; $retry_pkg = shift @transToInstall; $retry_count = 3; #- now it could be safe to display error message ? cdie("error installing package list: $name"); } } #- check if name has been set (so that the following code has been executed already). if (!$name && ($retry_pkg->flag_installed || !$retry_pkg->flag_selected)) { $retry_pkg->free_header; $retry_pkg = shift @transToInstall; $retry_count = 3; } } } cleanHeaders($prefix); } while $nb > 0 && !$pkgs::cancel_install; log::l("closing install.log file"); close $LOG; cleanHeaders($prefix); loopback::save_boot($loop_boot); } sub remove { my ($prefix, $toRemove, $packages) = @_; delete $packages->{rpmdb}; #- make sure rpmdb is closed before. return if $::g_auto_install || !@{$toRemove || []}; my $db = rpmDbOpenForInstall($prefix) or die "error opening RPM database: ", c::rpmErrorString(); my $trans = $db->create_transaction($prefix); foreach my $p (@$toRemove) { #- stuff remove all packages that matches $p, not a problem since $p has name-version-release format. $trans->remove($p); } eval { fs::mount("/proc", "$prefix/proc", "proc", 0) } unless -e "$prefix/proc/cpuinfo"; #- 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($db, 'user', undef, 'remove', scalar @$toRemove); if (my @probs = $trans->run(undef, force => 1)) { die "removing of old rpms failed:\n ", join("\n ", @probs); } else { #- clean ask_remove according to package marked to be deleted. if ($packages) { foreach my $p (@$toRemove) { delete $packages->{state}{ask_remove}{$p}; } } } #- keep in mind removing of these packages by cleaning $toRemove. @{$toRemove || []} = (); } sub selected_leaves { my ($packages) = @_; my @leaves; foreach (@{$packages->{depslist}}) { $_->flag_requested && !$_->flag_base and push @leaves, $_->name; } \@leaves; } sub naughtyServers_list { my ($quiet) = @_; my @_old_81 = qw( freeswan ); my @_old_82 = qw( vnc-server postgresql-server ); my @_old_92 = qw( postfix ypbind bind ibod ); my @_removed_92 = qw( mcserv samba lpr ); my @_moved_to_contrib_92 = qw( boa LPRng wu-ftpd am-utils ); my @new_80 = qw( jabber MySQL am-utils apache boa cfengine cups drakxtools-http finger-server imap leafnode lpr ntp openssh-server pidentd proftpd rwall rwho squid webmin wu-ftpd ); my @new_81 = qw( apache-mod_perl ftp-server-krb5 mcserv samba telnet-server-krb5 ypserv ); my @new_82 = qw( LPRng httpd-naat inn netatalk nfs-utils rusers-server samba-swat tftp-server ucd-snmp ); my @new_92 = qw( DansGuardian MySQL-Max clusternfs gkrellm-server lisa mon net-snmp openldap-servers samba-server saned vsftpd ); my @not_warned = qw( nfs-utils-clients portmap ); # X server (@new_80, @new_81, @new_82, @new_92, if_(!$quiet, @not_warned)); } sub naughtyServers { my ($packages) = @_; grep { my $p = packageByName($packages, $_); $p && $p->flag_selected; } naughtyServers_list('quiet'); } sub hashtree2list { my ($e, $h) = @_; my @l; my @todo = $e; while (@todo) { my $e = shift @todo; push @l, $e; push @todo, @{$h->{$e} || []}; } @l; } 1;