aboutsummaryrefslogtreecommitdiffstats
path: root/URPM/Build.pm
blob: d4921f2b328e64275ea9d0fbffb0f560be013882 (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
package URPM;

use strict;

#- prepare build of an hdlist from a list of files.
#- it can be used to start computing depslist.
#- parameters are :
#-   rpms     : array of all rpm file name to parse (mandatory)
#-   dir      : directory wich will contain headers (default to /tmp/.build_hdlist)
#-   callback : perl code to be called for each package read (default pack_header)
#-   clean    : bool to clean cache before (default no).
sub parse_rpms_build_headers {
    my ($urpm, %options) = @_;
    my ($dir, %cache, @headers);
    local (*DIR, *F);

    #- check for mandatory options.
    if (@{$options{rpms} || []} > 0) {
	#- build a working directory which will hold rpm headers.
	$dir = $options{dir} || ($ENV{TMPDIR} || "/tmp") . "/.build_hdlist";
	$options{clean} and system($ENV{LD_LOADER} ? $ENV{LD_LOADER} : @{[]}, "rm", "-rf", $dir);
	-d $dir or mkdir $dir, 0755 or die "cannot create directory $dir\n";

	#- examine cache if it contains any headers which will be much faster to read
	#- than parsing rpm file directly.
	unless ($options{clean}) {
	    opendir DIR, $dir;
	    while (my $file = readdir DIR) {
		my ($fullname, $filename) = $file =~ /(.+?-[^:\-]+-[^:\-]+\.[^:\-\.]+)(?::(\S+))?$/ or next;
		my @stat = stat "$dir/$_";
		$cache{$filename || $fullname} = { file => $file,
						   size => $stat[7],
						   time => $stat[9],
						 };
	    }
	    closedir DIR;
	}

	foreach (@{$options{rpms}}) {
	    my ($key) = m!([^/]*)\.rpm$! or next; #- get rpm filename.
	    my ($id, $filename);

	    if ($cache{$key} && $cache{$key}{time} > 0 && $cache{$key}{time} >= (stat $_)[9]) {
		($id, undef) = $urpm->parse_hdlist("$dir/$cache{$key}{file}", !$options{callback});
		defined $id or die "bad header $dir/$cache{$key}{file}\n";
		$options{callback} and $options{callback}->($urpm, $id, %options);

		$filename = $cache{$key}{file};
	    } else {
		($id, undef) = $urpm->parse_rpm($_);
		defined $id or die "bad rpm $_\n";

		my $pkg = $urpm->{depslist}[$id];

		$filename = $pkg->fullname;
		"$filename.rpm" eq $pkg->filename or $filename .= ":$key";

		print STDERR "$dir/$filename\n";
		unless (-s "$dir/$filename") {
		    open F, ">$dir/$filename" or die "unable to open $dir/$filename for writing\n";
		    $pkg->build_header(fileno *F);
		    close F;
		}
		-s "$dir/$filename" or unlink("$dir/$filename"), die "can create header $dir/$filename\n";

		#- make smart use of memory (no need to keep header in memory now).
		if ($options{callback}) {
		    $options{callback}->($urpm, $id, %options);
		} else {
		    $pkg->pack_header;
		}
	    }

	    #- keep track of header associated (to avoid rereading rpm filename directly
	    #- if rereading has been made neccessary).
	    push @headers, $filename;
	}
    }
    @headers;
}

#- allow rereading of hdlist and clean.
sub unresolved_provides_clean {
    my ($urpm) = @_;
    my @potentially_unresolved = keys %{$urpm->{provides} || {}};

    @$urpm{qw(depslist provides)} = ([], {});
    @{$urpm->{provides}}{@potentially_unresolved} = ();
}

#- read a list of headers (typically when building an hdlist when provides have
#- been cleaned.
#- parameters are :
#-   headers  : array of all headers file name to parse (mandatory)
#-   dir      : directory wich contains headers (default to /tmp/.build_hdlist)
#-   callback : perl code to be called for each package read (default pack_header)
sub parse_headers {
    my ($urpm, %options) = @_;
    my ($dir, $start, $id);

    $dir = $options{dir} || ($ENV{TMPDIR} || "/tmp") . "/.build_hdlist";
    -d $dir or die "no directory $dir\n";

    $start = @{$urpm->{depslist} || []};
    foreach (@{$options{headers} || []}) {
	#- make smart use of memory (no need to keep header in memory now).
	($id, undef) = $urpm->parse_hdlist("$dir/$_", !$options{callback});
	defined $id or die "bad header $dir/$_\n";
	$options{callback} and $options{callback}->($urpm, $id, %options);
    }
    defined $id ? ($start, $id) : @{[]};
}

#- compute dependencies, result in stored in info values of urpm.
#- operations are incremental, it is possible to read just one hdlist, compute
#- dependencies and read another hdlist, and again.
#- parameters are :
#-   callback : callback to relocate reference to package id.
sub compute_deps {
    my ($urpm, %options) = @_;
    my %propagated_weight = ( basesystem => 10000,
			      msec       => 20000,
			      filesystem => 50000,
			    );
    my ($locales_weight, $step_weight, $fixed_weight) = (-5000, 10000, $propagated_weight{basesystem});

    #- avoid recomputing already present infos, take care not to modify
    #- existing entries, as the array here is used instead of values of infos.
    my $start = @{$urpm->{deps} ||= []};
    my $end = $#{$urpm->{depslist} || []};

    #- check if something has to be done.
    $start > $end and return;

    #- take into account in which hdlist a package has been found.
    #- this can be done by an incremental take into account generation
    #- of depslist.ordered part corresponding to the hdlist.
    #- compute closed requires, do not take into account choices.
    foreach ($start .. $end) {
	my $pkg = $urpm->{depslist}[$_];

	my %required_packages;
	my @required_packages;
	my %requires; @requires{$pkg->requires_nosense} = ();
	my @requires = keys %requires;

	while (my $req = shift @requires) {
	    $req =~ /^basesystem/ and next; #- never need to requires basesystem directly as always required! what a speed up!
	    $req = ($req =~ /^\d+$/ && [ $req ] ||
		    $urpm->{provides}{$req} && [ keys %{$urpm->{provides}{$req}} ] ||
		    [ ($req !~ /NOTFOUND_/ && "NOTFOUND_") . $req ]);
	    if (@$req > 1) {
		#- this is a choice, no closure need to be done here.
		push @required_packages, $req;
	    } else {
		#- this could be nothing if the provides is a file not found.
		#- and this has been fixed above.
		foreach (@$req) {
		    my $pkg_ = /^\d+$/ && $urpm->{depslist}[$_];
		    exists $required_packages{$_} and next;
		    $required_packages{$_} = undef; $pkg_ or next;
		    foreach ($pkg_->requires_nosense) {
			unless (exists $requires{$_}) {
			    $requires{$_} = undef;
			    push @requires, $_;
			}
		    }
		}
	    }
	}
	#- examine choice to remove those which are not mandatory.
	foreach (@required_packages) {
	    unless (grep { exists $required_packages{$_} } @$_) {
		$required_packages{join '|', sort { $a <=> $b } @$_} = undef;
	    }
	}

	#- store a short representation of requires.
	$urpm->{requires}[$_] = join ' ', keys %required_packages;
    }

    #- expand choices and closure again.
    my %ordered;
    foreach ($start .. $end) {
	my @requires = $_;
	my ($dep, %requires);
	while (defined ($dep = shift @requires)) {
	    exists $requires{$dep} || /^[^\d\|]*$/ and next;
	    foreach ($dep, split ' ', (defined $urpm->{deps}[$dep] ? $urpm->{deps}[$dep] : $urpm->{requires}[$dep])) {
		if (/\|/) {
		    push @requires, split /\|/, $_;
		} else {
		    /^\d+$/ and $requires{$_} = undef;
		}
	    }
	}

	my $pkg = $urpm->{depslist}[$_];
	my $delta = 1 + $propagated_weight{$pkg->name};
	foreach (keys %requires) {
	    $ordered{$_} += $delta;
	}
    }

    #- some package should be sorted at the beginning.
    foreach (qw(basesystem msec rpm locales filesystem setup glibc sash bash libtermcap2 termcap readline ldconfig)) {
	foreach (keys %{$urpm->{provides}{$_} || {}}) {
	    /^\d+$/ and $ordered{$_} = $fixed_weight;
	}
	/locales/ and $locales_weight += $fixed_weight;
	$fixed_weight += $step_weight;
    }
    foreach ($start .. $end) {
	my $pkg = $urpm->{depslist}[$_];

	$pkg->name =~ /locales-[a-zA-Z]/ and $ordered{$_} = $locales_weight;
    }

    #- compute base flag, consists of packages which are required without
    #- choices of basesystem and are ALWAYS installed. these packages can
    #- safely be removed from requires of others packages.
    foreach (qw(basesystem glibc kernel)) {
	foreach (keys %{$urpm->{provides}{$_} || {}}) {
	    foreach ($_, split ' ', (defined $urpm->{deps}[$_] ? $urpm->{deps}[$_] : $urpm->{requires}[$_])) {
		/^\d+$/ and $urpm->{depslist}[$_] and $urpm->{depslist}[$_]->set_flag_base(1);
	    }
	}
    }

    #- give an id to each packages, start from number of package already
    #- registered in depslist.
    my %remap_ids; @remap_ids{sort {
	$ordered{$b} <=> $ordered{$a} or do {
	    my ($na, $nb) = map { $urpm->{depslist}[$_]->name } ($a, $b);
	    my ($sa, $sb) = map { /^lib(.*)/ and $1 } ($na, $nb);
	    $sa && $sb ? $sa cmp $sb : $sa ? -1 : $sb ? 1 : $na cmp $nb;
	} } ($start .. $end)} = ($start .. $end);

    #- recompute requires to use packages id, drop any base packages or
    #- reference of a package to itself.
    my @depslist;
    foreach ($start .. $end) {
	my $pkg = $urpm->{depslist}[$_];

	#- set new id.
	$pkg->set_id($remap_ids{$_});

	my ($id, $base, %requires_id, %not_founds);
	foreach (split ' ', $urpm->{requires}[$_]) {
	    if (/\|/) {
		#- all choices are grouped together at the end of requires,
		#- this allow computation of dropable choices.
		my ($to_drop, @choices_base_id, @choices_id);
		foreach (split /\|/, $_) {
		    my ($id, $base) = (exists($remap_ids{$_}) ? $remap_ids{$_} : $_, $urpm->{depslist}[$_]->flag_base);
		    $base and push @choices_base_id, $id;
		    $base &&= ! $pkg->flag_base;
		    $to_drop ||= $id == $pkg->id || exists $requires_id{$id} || $base;
		    push @choices_id, $id;
		}

		#- package can safely be dropped as it will be selected in requires directly.
		$to_drop and next;

		#- if a base package is in a list, keep it instead of the choice.
		if (@choices_base_id) {
		    @choices_id = @choices_base_id;
		    $base = 1;
		}
		if (@choices_id == 1) {
		    $id = $choices_id[0];
		} else {
		    my $choices_key = join '|', sort { $a <=> $b } @choices_id;
		    $requires_id{$choices_key} = undef;
		    next;
		}
	    } elsif (/^\d+$/) {
		($id, $base) =  (exists($remap_ids{$_}) ? $remap_ids{$_} : $_, $urpm->{depslist}[$_]->flag_base);
	    } else {
		$not_founds{$_} = undef;
		next;
	    }

	    #- select individual package from choices or defined package.
	    $base &&= ! $pkg->flag_base;
	    $base || $id == $pkg->id or $requires_id{$id} = undef;
	}
	#- be smart with memory usage.
	delete $urpm->{requires}[$_];
	$urpm->{deps}[$remap_ids{$_}] = join ' ', ((sort { ($a =~ /^(\d+)/)[0] <=> ($b =~ /^(\d+)/)[0] } keys %requires_id),
						   keys %not_founds);
	$depslist[$remap_ids{$_}-$start] = $pkg;
    }

    #- remap all provides ids for new package position and update depslist.
    delete $urpm->{requires};
    @{$urpm->{depslist}}[$start .. $end] = @depslist;
    foreach my $h (values %{$urpm->{provides}}) {
	my %provided;
	foreach (keys %{$h || {}}) {
	    $provided{exists($remap_ids{$_}) ? $remap_ids{$_} : $_} = delete $h->{$_};
	}
	$h = \%provided;
    }
    $options{callback} and $options{callback}->($urpm, \%remap_ids, %options);

    ($start, $end);
}

#- build an hdlist from existing depslist, from start to end inclusive.
#- parameters are :
#-   hdlist   : hdlist file to use.
#-   dir      : directory wich contains headers (default to /tmp/.build_hdlist)
#-   start    : index of first package (default to first index of depslist).
#-   end      : index of last package (default to last index of depslist).
#-   ratio    : compression ratio (default 4).
#-   split    : split ratio (default 400000).
sub build_hdlist {
    my ($urpm, %options) = @_;
    my ($dir, $start, $end, $ratio, $split);

    $dir = $options{dir} || ($ENV{TMPDIR} || "/tmp") . "/.build_hdlist";
     -d $dir or die "no directory $dir\n";

    $start = $options{start} || 0;
    $end = $options{end} || $#{$urpm->{depslist}};

    #- compression ratio are not very high, sample for cooker
    #- gives the following (main only and cache fed up):
    #- ratio compression_time  size
    #-   9       21.5 sec     8.10Mb   -> good for installation CD
    #-   6       10.7 sec     8.15Mb
    #-   5        9.5 sec     8.20Mb
    #-   4        8.6 sec     8.30Mb   -> good for urpmi
    #-   3        7.6 sec     8.60Mb
    $ratio = $options{ratio} || 4;
    $split = $options{split} || 400000;

    local *B;
    open B, "| " . ($ENV{LD_LOADER} || '') . " packdrake -b${ratio}ds '$options{hdlist}' '$dir' $split";
    foreach my $pkg (@{$urpm->{depslist}}[$start .. $end]) {
	my $filename = $pkg->fullname;
	"$filename.rpm" ne $pkg->filename && $pkg->filename =~ m!([^/]*)\.rpm$! and $filename .= ":$1";
	-s "$dir/$filename" or die "bad header $dir/$filename\n";
	print B "$filename\n";
    }
    close B or die "packdrake failed\n";
}

#- build synthesis file.
#- parameters are :
#-   synthesis : synthesis file to create (mandatory if fd not given).
#-   fd        : file descriptor (mandatory if synthesis not given).
#-   dir       : directory wich contains headers (default to /tmp/.build_hdlist)
#-   start     : index of first package (default to first index of depslist).
#-   end       : index of last package (default to last index of depslist).
#-   ratio     : compression ratio (default 9).
sub build_synthesis {
    my ($urpm, %options) = @_;
    my ($start, $end, $ratio);

    $start = $options{start} || 0;
    $end = $options{end} || $#{$urpm->{depslist}};
    $start > $end and return;
    $ratio = $options{ratio} || 9;
    $options{synthesis} || defined $options{fd} or die "invalid parameters given";

    #- first pass: traverse provides to find files provided.
    my %provided_files;
    foreach (keys %{$urpm->{provides}}) {
	m!^/! or next;
	foreach my $id (keys %{$urpm->{provides}{$_} || {}}) {
	    push @{$provided_files{$id} ||= []}, $_;
	}
    }


    #- second pass: write each info including files provided.
    local *F;
    $options{synthesis} and open F, "| " . ($ENV{LD_LOADER} || '') . " gzip -$ratio >'$options{synthesis}'";
    foreach ($start .. $end) {
	my $pkg = $urpm->{depslist}[$_];
	my %files;

	if ($provided_files{$_}) {
	    @files{@{$provided_files{$_}}} = undef;
	    delete @files{$pkg->provides_nosense};
	}

	$pkg->build_info($options{synthesis} ? fileno *F : $options{fd}, join('@', keys %files));
    }
    close F;
}

#- write depslist.ordered file according to info in params.
#- parameters are :
#-   depslist : depslist.ordered file to create.
#-   provides : provides file to create.
#-   compss   : compss file to create.
sub build_base_files {
    my ($urpm, %options) = @_;
    local *F;

    if ($options{depslist}) {
	open F, ">$options{depslist}";
	foreach (0 .. $#{$urpm->{depslist}}) {
	    my $pkg = $urpm->{depslist}[$_];

	    printf F ("%s-%s-%s.%s%s %s %s\n", $pkg->fullname,
		      ($pkg->epoch ? ':' . $pkg->epoch : ''), $pkg->size || 0, $urpm->{deps}[$_]);
	}
	close F;
    }

    if ($options{provides}) {
	open F, ">$options{provides}";
	while (my ($k, $v) = each %{$urpm->{provides}}) {
	    printf F "%s\n", join '@', $k, map { scalar $urpm->{depslist}[$_]->fullname } keys %{$v || {}};
	}
	close F;
    }

    if ($options{compss}) {
	my %p;

	open F, ">$options{compss}";
	foreach (@{$urpm->{depslist}}) {
	    $_->group or next;
	    push @{$p{$_->group} ||= []}, $_->name;
	}
	foreach (sort keys %p) {
	    print F $_, "\n";
	    foreach (@{$p{$_}}) {
		print F "\t", $_, "\n";
	    }
	    print F "\n";
	}
	close F;
    }

    1;
}

1;