source: soft/build_system/build_system/mkcd/trunk/pm/Mkcd/Tools.pm @ 1

Last change on this file since 1 was 1, checked in by fasma, 12 years ago

Initial Import from Mandriva's soft revision 224062 and package revision 45733

File size: 33.9 KB
Line 
1package Mkcd::Tools;
2
3our $VERSION = '1.0.0';
4
5use strict;
6use File::NCopy qw(copy);       
7use Image::Size qw(:all);
8use Mkcd::Commandline qw(parseCommandLine usage);
9use Digest::MD5;
10use MDK::Common qw(all any cat_ member);
11use MDV::Packdrakeng;
12use MDV::Distribconf::Build;
13
14require Exporter;
15use URPM;
16our @ISA = qw(Exporter);;
17our @EXPORT = qw(printTable getTracks du cpal checkcds checkDiscs cleanrpmsrate imageSize printDiscsFile readBatchFile printBatchFile config compute_md5 log_ include_md5 convert_size compute_files_md5 fix_dir filter_path find_list);
18our ($GB, $MB, $KB, $INFO_OFFSET, $SIZE_OFFSET, $SKIP);
19$INFO_OFFSET = 883;
20$SIZE_OFFSET = 84;
21$SKIP = 15;
22
23$KB = 1024;
24$MB = 1024 * 1024;
25$GB = $MB * 1024;
26
27=head1 NAME
28
29tools - mkcd tools
30
31=head1 SYNOPSYS
32
33    require mkcd::tools;
34
35=head1 DESCRIPTION
36
37<mkcd::tools> includes mkcd tools.
38
39=head1 SEE ALSO
40
41mkcd
42
43=head1 COPYRIGHT
44
45Copyright (C) 2000,2001,2002,2003,2004 Mandriva <warly@mandriva.com>
46
47This program is free software; you can redistribute it and/or modify
48it under the terms of the GNU General Public License as published by
49the Free Software Foundation; either version 2, or (at your option)
50any later version.
51
52This program is distributed in the hope that it will be useful,
53but WITHOUT ANY WARRANTY; without even the implied warranty of
54MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
55GNU General Public License for more details.
56
57You should have received a copy of the GNU General Public License
58along with this program; if not, write to the Free Software
59Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
60
61=head1 CREDITS
62
63md5 code highly inspired from Redhat anaconda md5 in ISO code
64
65=cut
66
67sub printTable {
68    my ($a, $log) = @_;
69    my $LOG; if ($log) { $LOG = $log } else { open $LOG, ">&STDERR" }
70    #
71    # iterative version of a recursive scanning of a table.
72    # ex: @config = [[[1,3],3,[1,3,[1,3]]],3,4,[4,[4,4]]]
73    #   
74    my @A;
75    my @i;
76    my @tab;
77    my $i = 0;
78    while ($a) {
79        my $u = ref $a;
80        if ($u eq 'ARRAY') {
81            while ($i < @$a) {
82                my $b = $a->[$i];
83                my $t = ref $b;
84                if ($t eq 'ARRAY') {
85                    push @tab, "\t";
86                    push @i, $i+1;
87                    push @A, $a;
88                    $i = 0;
89                    $a = $b;
90                    next
91                } elsif ($t eq 'HASH') { 
92                    $i++; print $LOG "@tab", join ' ', keys %$b, "\n"
93                } else { $i++; print $LOG "@tab$b\n" }
94            }
95        } else { print $LOG "$a\n" }
96        pop @tab;
97        $i = pop @i;
98        $a = pop @A;
99    }
100
101}
102
103sub getTracks {
104    my ($tracks, $log) = @_;
105    my $LOG; if ($log) { $LOG = $log } else { open $LOG, ">&STDERR" }
106    my @tracks = split ',',$tracks;
107    my @t;
108    foreach (@tracks) {
109        /(\d+)/ and push @t, $1;
110        /(\d+)-(\d+)/ and push @t, $1..$2       
111    }
112    my @ntracks;
113    my %done;
114    for (my $i = $#t; $i >= 0; $i--) {
115        push @ntracks, $t[$i] if !$done{$t[$i]};
116        $done{$t[$i]}=1
117    }
118    \@ntracks;
119}
120
121sub du {
122    my ($path, $inode, $stat) = @_;
123    my $size;
124    $inode ||= {};
125    if (-d $path) {
126        opendir O, $path;
127        foreach (readdir O) {
128            /^\.{1,2}$/ and next;
129            -l "$path/$_" or $size += du("$path/$_",$inode)
130        }
131    } else {
132        if (! -l $path) {
133            # stat values are false for directory, and should only be used for singe file size
134            $stat ||= [];
135            @$stat = stat $path;
136            if (!$inode->{$stat->[0]}{$stat->[1]}) {
137                # keep an extra size regarding iso9660 inode size
138                $size = $stat->[7] + 2048;
139                $inode->{$stat->[0]}{$stat->[1]} = 1
140            }
141        }
142    }
143    $size
144}
145
146sub cpal {
147    my ($source, $dest, $exclude, $verbose, $log) = @_;
148    my $LOG; if ($log) { $LOG = $log } else { open $LOG, ">&STDERR" }
149    if ($exclude && "$source/$_" =~ /$exclude/) { return 0 }
150    if (!-l $source && -d $source) {
151        mkdir $dest;
152        opendir O, $source; 
153        foreach (readdir O) {
154            /^\.{1,2}$/ and next;
155            cpal("$source/$_", "$dest/$_",$exclude,$verbose)
156        }
157    } else {
158        my $ok;
159        if (-d $dest) { my ($filename) = $source =~ m,([^/]*)$,; $dest .= "/$filename" }
160        $ok = link $source, $dest;
161        $verbose and print $LOG "cpal: link $source -> $dest\n";
162        if (!$ok) {
163            print $LOG "Linking failed $source -> $dest: $!, trying to copy\n";
164            if (-l $source) {
165                $ok = symlink(readlink($source), $dest);
166            } else {
167                $ok = copy $source, $dest;
168            }
169            if (!$ok) { print $LOG "Copying failed $source -> $dest: $!,\n"; return 0 }
170        }
171    }
172    1
173}
174
175sub checkDiscs {
176    my ($hdlists, $depslist, $discsFiles, $check, $dup, $log) = @_;
177    my $LOG; if ($log) { $LOG = $log } else { open $LOG, ">&STDOUT" }
178   
179    print $LOG "checkDiscs: depslist $depslist\n";
180    #
181    # depslist hdlist consistency -> error                        ok (not the same as install one, but duplicate will break anyway)
182    #
183    # in hdlist, not in depslist -> error                         ok
184    #
185    # in hdlist, not in dir -> error                              ok
186    #
187    # in hdlist with packdrake, no with parsehdlist -> error
188    #
189    # in depslist, not in hdlist -> error                         ok
190    #
191    # in depslist, not in dir -> error                            ok
192    #
193    # in dir, not in hdlist -> warning                            ok
194    #
195    # in dir, not in depslist -> warning                          ok
196    #
197    # multiple version in depslist -> error                       ok
198    #
199    # multiple version in hdlist -> error                         ok
200    #
201    # multiple in dir -> warning                                  ok
202    #
203   
204    my $ok = 1;
205    my $OK = 1;
206    my %depslist;
207    my %depslistname;
208    if ($depslist) {
209        my $i = 1;
210        open my $A, $depslist or print $LOG "ERROR: unable to open $depslist" and return 0;
211        print $LOG "checkDiscs: duplicate version in $depslist:";
212        while (<$A>) {
213            my ($pkg, $name, $arch) = ((split)[0]) =~ m/((.*)-[^-]+-[^-]+\.([^:]+))/;
214            $depslist{$pkg} and do { print $LOG "\n$pkg"; $ok = 0 };
215            $depslistname{$arch}{$name} and do { print $LOG "\n$name"; $ok = 0 };
216            $depslist{$pkg} = $i;
217            $depslistname{$arch}{$name} = $i++;
218        }
219        close $A;
220    }
221    $ok or $OK = 0;
222    if ($dup) {
223        $ok ? print $LOG " OK\n" : print $LOG "\nFAILED\n"
224    } else {
225        $ok ? print $LOG " OK\n" : print $LOG "\nWARNING (dup mode activated)\n";
226        $OK = 1
227    }
228    my %hdlist;
229    print $LOG "\ncheckDiscs: duplicate version in hdlists:";
230    my $maxidx;
231    my %rpm;
232    my (@rnh, @hnd, @duprep, @rnd, @hnr, %rpmKeys, %parsehdlist, @pnh, @hnp);
233    $ok = 1;
234    my $parsehdlist;
235    my $path = $0;
236    $path =~ s,[^/]*$,,;
237    if (-x "$path/parsehdlist") {
238        $parsehdlist = "$path/parsehdlist"
239    } elsif (-x "/usr/bin/parsehdlist") {
240        $parsehdlist = "/usr/bin/parsehdlist"
241    } else {
242        my $err = system('parsehdlist');
243        if ($err) {
244            $parsehdlist = "parsehdlist"       
245        } else {
246            print $LOG, "ERROR checkDiscs: could not find parsehdlist command ($!)\n";
247            return 0
248        }
249    }
250    for (my $i = 1; $i < @$hdlists; $i++) {
251        if (! -f $hdlists->[$i]) {
252            print $LOG "\nWARNING checkDiscs: $hdlists->[$i] is empty, ignoring\n";
253            next
254        }
255        my $j;
256        my $packer = MDV::Packdrakeng->open(archive => $hdlists->[$i]);
257        foreach my $file (keys %{$packer->{files}}) {
258            my ($rpm, $key) = $file =~ /([^:]*)(?::(.*))?/;
259            $rpmKeys{key}{$rpm} = $key || $rpm;
260            $rpmKeys{rpm}{$rpmKeys{key}{$rpm}} = $rpm;
261            my $sok;
262            foreach my $c (@{$check->[$i]}) {
263                my ($cd, $rep, $list) = @$c;
264                $discsFiles->[$cd]{$rep}{$list}{$rpmKeys{key}{$rpm}} and $sok = 1;
265            }
266            $sok or push @hnr, [ $i, $rpm ];
267            $hdlist{all}{$rpm} and do { print $LOG "\n$rpm"; $ok = 0 };
268            $hdlist{all}{$rpm} = 1;
269            $hdlist{cd}{$i}{$rpm}  = 1;
270            if ($depslist) {
271                $depslist{$rpm} or push @hnd, $rpm;
272                $depslist{$rpm} > $j and $j = $depslist{$rpm};
273                $depslist{$rpm} < $maxidx and print $LOG "ERROR checkDiscs: inconsistency in position between hdlist $i rpm $rpm and depslist.ordered ($j < $maxidx)\n"
274            }
275        }
276        foreach my $c (@{$check->[$i]}) {
277            my ($cd, $rep, $list) = @$c;
278            foreach my $rpm (keys %{$discsFiles->[$cd]{$rep}{$list}}) {
279                $rpm{$rpmKeys{rpm}{$rpm}} and push @duprep, $rpm;
280                $rpm{$rpmKeys{rpm}{$rpm}} = 1;
281                $depslist && $depslist{$rpmKeys{rpm}{$rpm}} or push @rnd,  [ $i, $cd, $rep, $rpm ];
282                $hdlist{cd}{$i}{$rpmKeys{rpm}{$rpm}} or push @rnh, [ $i, $rpm ]
283            }
284        }
285        open my $PAR, "$parsehdlist $hdlists->[$i] |";
286        while (<$PAR>) {
287            chomp;
288            s/\.rpm$//;
289            $parsehdlist{$i}{$_} = 1;
290            $hdlist{cd}{$i}{$_} and next;
291            push @pnh, $_
292        }
293        foreach my $p (keys %{$hdlist{cd}{$i}}) {
294            $parsehdlist{$i}{$p} or push @hnp, $p
295        }
296        $maxidx = $j;
297    }
298    $ok or $OK = 0;
299    $ok ? print $LOG " OK\n" : print $LOG "\nFAILED\n";
300
301    my @dnh;
302    $ok = 1;
303    if ($depslist) {
304        print $LOG "\ncheckDiscs: in depslist, not on discs:";
305        foreach my $rpm (keys %depslist) {
306            $hdlist{all}{$rpm} or do { push @dnh, $rpm };
307            $rpm{$rpm} or do { $ok = 0; print $LOG "\n$rpm" };
308        }
309        $ok or $OK = 0;
310        $ok ? print $LOG " OK\n" : print $LOG "\nFAILED\n";
311
312        print $LOG "\ncheckDiscs: in depslist, not in hdlists:";
313        @dnh ? do { print $LOG " FAILED\n" and $OK = 0 } : print $LOG " OK\n";
314        foreach (@dnh) {
315            print $LOG "$_\n"
316        }
317    }
318    print $LOG "\ncheckDiscs: in hdlists, not on discs:";
319    @hnr ? do { print $LOG " FAILED\n" and $OK = 0 } : print $LOG " OK\n";
320    foreach (@hnr) {
321        print $LOG "hdlist $_->[0] rpm $_->[3]\n"
322    }
323    print $LOG "\ncheckDiscs: in hdlists, not in depslist:";
324    @hnd ? do { print $LOG " FAILED\n" and $OK = 0 } : print $LOG " OK\n";
325    foreach (@hnd) {
326        print $LOG "$_\n"
327    }
328    print $LOG "\ncheckDiscs: in hdlists, not see with parsehdlist:";
329    @hnp ? do { print $LOG " FAILED\n" and $OK = 0 } : print $LOG " OK\n";
330    foreach (@hnp) {
331        print $LOG "$_\n"
332    }
333    print $LOG "\ncheckDiscs: see with parsehdlist, not with packdrake:";
334    @pnh ? do { print $LOG " FAILED\n" and $OK = 0 } : print $LOG " OK\n";
335    foreach (@pnh) {
336        print $LOG "$_\n"
337    }
338    print $LOG "\ncheckDiscs: on discs, not in hdlist:";
339    @rnh ? print $LOG " WARNING\n" : print $LOG " OK\n";
340    foreach (@rnh) {
341        print $LOG "hdlist $_->[0] rpm $_->[1]\n"
342    }
343    print $LOG "\ncheckDiscs: on discs, not in depslist:";
344    @rnd ? print $LOG " WARNING\n" : print $LOG " OK\n";
345    foreach (@rnd) {
346        print $LOG "hdlist $_->[0] cd $_->[1] rep $_->[2] missing rpm $_->[3]\n"
347    }
348    print $LOG "\ncheckDiscs: duplicate version on discs:";
349    @duprep ? print $LOG " WARNING\n" : print $LOG " OK\n";
350    foreach (@duprep) {
351        print $LOG "$_\n"
352    }
353    return $OK
354}
355
356#
357# check depslist, depslists.ordered and hdlists
358#
359sub checkcds {
360    my (@tops) = @_;
361   
362    my $top = "$tops[0]/";
363    my $depslist;
364    my $media_info;
365    if (-d "$tops[0]/media/media_info") {
366        $depslist = "$tops[0]/media/media_info/depslist.ordered";
367        $media_info = "media/media_info"
368    } else {
369        $depslist = "$tops[0]/Mandrake/base/depslist.ordered";
370        $media_info = "Mandrake/base"
371    }
372    -f $depslist or print "ERROR: could not find depslist $depslist file\n" and return 0;
373    my @hdlist = 0;
374    my @discsFiles;
375    my @check = 0;
376    my $use_distribconf = 1;
377    if ($use_distribconf) {
378        my $distrib = MDV::Distribconf::Build->new($top);
379        if (!$distrib->loadtree) {
380            $use_distribconf = 0
381        }
382        $distrib->parse_mediacfg;
383        foreach my $media ($distrib->listmedia) {
384            my $dir = $distrib->getpath($media, 'path');
385            my $hdfile = $distrib->getfullpath($media,'hdlist');
386            my ($hdid) = $hdfile =~ /hdlist([^\/]*).cz/;
387            print "$dir, $hdfile\n";   
388            push @hdlist, $hdfile;
389            push @check, [[ $hdid, $dir, 1 ]];
390        }
391    }
392    if (!$use_distribconf) {
393        my $hdlists = "$top/$media_info/hdlists";
394        open my $A, $hdlists or die "unable to open $hdlists";
395        while (<$A>) {
396            my ($hdlist, $dir, undef) = split;
397            my ($hdid) = $hdlist =~ /hdlist(.*).cz/;
398            my $hdfile = "$top/$media_info/$hdlist";
399            push @hdlist, $hdfile;
400            push @check, [[ $hdid, $dir, 1 ]];
401        }
402    }
403    for (my $i = 1; $i < @hdlist; $i++) {
404        my $hdfile = $hdlist[$i];
405        -f $hdfile or print "ERROR: could not find $hdfile file\n" and return 0;
406        my ($hdid, $dir) = @{$check[$i][0]};
407        print "Reading $top/$dir\n";
408        my $C;
409        if (! opendir $C, "$top/$dir") {
410            foreach (@tops) {
411                opendir $C, "$_/$dir" or next;
412                last
413            }
414        }
415        foreach (readdir $C) {
416            /(.*)\.rpm/ or next;
417            $discsFiles[$hdid]{$dir}{1}{$1} = 1
418        }
419    }
420    checkDiscs(\@hdlist, $depslist, \@discsFiles, \@check)
421}
422
423sub cleanrpmsrate {
424    my ($rpmsrate, $output, $norpmsrate, $reprpms, $urpm) = @_;
425    $norpmsrate ||= [];
426    my $LOG; open $LOG, ">&STDERR";
427    open my $A, $rpmsrate or print $LOG "ERROR: cannot open $rpmsrate\n";
428    my (@rpmsrate, %potloc);
429    # must preread to get locale guessed packages
430    # postfix is just used not to break the diff when checking if the result is correct
431    while (<$A>) {
432        chomp;
433        s/#.*//;
434        #s/\s*$//;
435        /^(\s*)$/ and push @rpmsrate, [ '', 0, '', [] ] and next;
436        if (/^(\S+)(.*)$/) {
437            push @rpmsrate, [ 0, 0, $1, [], $2 ];
438            next
439        }
440        if (/^(\s*)([1-5])?(\s?[0-9A-Z_]+)$/) {
441            push @rpmsrate, [ $1, $2, $3, [] ];
442            next
443        }
444        my ($indent, $r, $flags, $data) = /^(\s*)([1-5])?(\s*(?:(?:(?:!\s*)?[0-9A-Z_]+(?:"[^"]*")?(?:\s+(?:\|\|\s+)?)*)+\s+)|\s*)(.*)$/;
445        my ($postfix) = $data =~ /(\s*)$/;
446        my @data;
447        my $i;
448        foreach ([$data =~ /(?:^|\s)(\S+)-(?:\S+)\s+\1-(?:\S+)(?:\s|$)/g], [split ' ', $data]) {
449            $data[$i++] = [ @$norpmsrate ? any { my $r = $_; $r if !any { $r =~ /$_/ } @$norpmsrate } @$_ : @$_ ]
450        }
451        $potloc{$_} = [] foreach  @{$data[0]};
452        push @rpmsrate, [ $indent,$r, $flags, $data[1], $postfix ];
453    }
454    my (%rpms, $text);
455    my (%rate, %section, %keyword);
456    my (%locale, %localized_pkg, %kernel_version);
457    my @plain_flags = qw(INSTALL LIVE);
458    my $kernel_like = "((?:(?:NVIDIA_)?kernel|NVIDIA_nforce|cm2020).*)";
459    my $dkms_like = "(.*)([-_])kernel-([0-9]+(?:\.[0-9]+){2,3}-[0-9]+(?:.[^.]+){0,2}md[vk])(.*)";
460    my $rpmsrate_dkms_like = "(.*[-_]kernel)(.*)";
461    my $urpm2 = new URPM;
462    foreach my $dir (keys %$reprpms) {
463        foreach (@{$reprpms->{$dir}}) { 
464            my $rpm = "$_.rpm";
465            my $key = $_;
466            s/-[^-]+-[^-]+\.[^.]+$// or next;
467            any { $rpm =~ /$_/ } @$norpmsrate and next;
468            if (/(.*?)([_-]*[\d._]+)(-.*)?-devel$/ || /^$kernel_like(-[^.]+(?:\.[^.]+){3,6}md[vk])$/) { 
469                if (!$rpms{"$1$3"}) { $rpms{"$1$3"} = [ $2, $1, $3 ] }
470                elsif (URPM::ranges_overlap("== $2", "> $rpms{'$1$3'}")) { $rpms{"$1$3"} = [ $2, $1, $3 ] }
471                if (/^$kernel_like-(\d+\.\d+)(.*)/) { $rpms{"$1-$2"} = [ $3, "$1-$2" ]}
472            } elsif (/^$dkms_like$/) {
473                my $vname = "$1$2kernel$4";
474                if (!$rpms{$vname}) { $rpms{$vname} = [ $3, $vname ] }
475                elsif (URPM::ranges_overlap("== $3", "> $rpms{$vname}[0]")) { $rpms{$vname} = [ $3, $vname ] }
476            } elsif (my ($pg, $loc) = /^(.*)-([^-+]+)$/) {
477                if ($potloc{$pg}) {
478                    my $pkg;
479                    $pkg = $urpm->{rpm}{$urpm->{rpmkey}{key}{$key}} if ref $urpm;
480                    if (!$pkg) {
481                        my $id = $urpm2->parse_rpm("$dir/$rpm");
482                        $pkg = $urpm2->{depslist}[$id];
483                    }
484                    if (!$pkg) {
485                        print "ERROR cleanrpmsrate: parse_rpm $dir/$rpm ($key) failed\n";
486                        next
487                    }
488                    # some i18n packages does not require the same locale, e.g. kde-i18n-nb and nn requires locales-no
489                    # if (grep { s/locales-// && $loc =~ /^$_(_|$)/ } @{$header{REQUIRENAME}}) {
490                    if (any { /^locales-...?$/ } $pkg->requires) {
491                        push @{$locale{$pg}}, $loc;
492                        $localized_pkg{"$pg-$loc"} = 1
493                    }
494                }
495            }
496        }
497    }
498    my (%done, @flags, $prev, @tree_rate, $prev_level);
499    foreach (@rpmsrate) {
500        if (!$_->[0]) {
501            $text .= "$_->[2]$_->[4]\n";
502            if ($_->[2]) {
503                @flags = $_->[2]
504            }
505            next
506        }
507        my ($indent, $r, $flags, $data, $postfix) = @$_;
508        my $level = (length $indent)/2 - 1;
509        my $rate;
510        if ($r) {
511            #print "tree_rate[$level] = $r\n";
512            $rate = $r;
513            $tree_rate[$level] = $r
514        } else {
515            if (@$data) {
516                if ($level > $prev_level) {
517                    $level-- 
518                } else {
519                    # fix a syntax error in rpmsrate such as
520                    # A
521                    #   1 toto
522                    #   B tata <---
523                    #     4 titi
524                    @$data = ()
525                }
526            }
527            $rate = $tree_rate[$level];
528        }
529        $prev_level = $level;
530        @flags = @flags[0 .. $level];
531        push @flags, split(' ', $flags);
532        #push @flags, grep { s/\s//; !/(\|\||[A-Z_]+"[^"]+")/ } split(' ', $flags);
533        my $flat_path = join ' ', @flags;
534        if (!@$data) { $text .= "$indent$r$flags$postfix\n"; next }
535        my @k;
536        foreach (@$data) {
537            my $c = $_;
538            next if ref $done{$_} && any { $flat_path eq $_ } @{$done{$_}};
539            die "FATAL: too complicated flags for duplicate entry $c ($flat_path and " . join ',', @{$done{$_}} 
540                 if !member($flags[0], @plain_flags) && @flags > 1 && any { 
541                         my ($f) = $flat_path =~ /^[^ ]+ (.*)/;
542                         !/^[^ ]+ (.*)/ || $1 ne $f
543                 } @{$done{$_}};
544            my ($d) = /(.*)-[^-]+/;
545            my ($a, $b, $e);
546            my $do;
547            if ((!member($flags[0], @plain_flags) && s/(-devel)// ? ($b = "-devel") : /^$kernel_like/) && (($rpms{$_}) || (defined $rpms{"lib$_"} and $a = "lib") || (defined $rpms{"lib64$_"} and $a = "lib64") || ($_ =~ s/^lib(.*?)[_-]*[\d._]*(-.*)?$/$1$2/g && defined $rpms{"lib64$_"} and $a = 'lib64'))) {
548                $e = $rpms{"$a$_"}[1] . $rpms{"$a$_"}[0] . $rpms{"$a$_"}[2] . $b;
549                $do = 1
550            } elsif ((!member($flags[0], @plain_flags) && /^$rpmsrate_dkms_like$/ && $rpms{"$1$2"})) {
551                $e = "$1-" . $rpms{"$1$2"}[0] . "$2";
552                $do = 1
553            }
554            if ($do) {
555                $keyword{$c} = $e;
556                if (! ref $done{$e} || member($flags[0], @plain_flags) && ! (any { $flat_path eq $_ } @{$done{$e}}) || $flat_path =~ /DRIVER|HW/ ) { push @{$done{$e}}, $flat_path; push @k, $e }
557            }
558            if ($locale{$d} && $localized_pkg{$c}) {
559                foreach (sort @{$locale{$d}}) {
560                    next if any { $_ eq $flat_path } @{$done{"$d-$_"}};
561                    push @{$done{"$d-$_"}}, $flat_path; 
562                    push @k , "$d-$_"
563                }
564                next
565            }
566            push @k, $c;
567            push @{$done{$c}}, $flat_path
568        } 
569        if (@k) { $text .= "$indent$r$flags@k$postfix\n" }
570        @rate{@k} = ($rate) x @k;
571        my $path;
572        foreach (@flags) {
573            $path .= $path ? "/$_" : $_;
574            push @{$section{$path}}, @k
575        }
576    }
577    if (%rpms || $output || %locale) {
578        if (%$reprpms || $output) {
579            $output ||= $rpmsrate;
580            if (open A, ">$output") { 
581                print A $text;
582                close A
583            } else { 
584                print $LOG "ERROR cleanrpmsrate: cannot open $rpmsrate for writing\n";
585                print $text
586            }
587        }
588    }
589    [\%rate, \%section, \%keyword]
590}
591
592sub imageSize {
593    my ($file) = @_;
594    my ($width, $height, $err) = imgsize $file;
595
596    return (defined $width ?
597    [ $width, $height ] :
598    "error: $err")
599}
600
601sub printDiscsFile {
602    my ($config, $discsFiles, $PRINT, $metagroups) = @_;
603    my (%done, $output);
604    my $log = $config->{LOG};
605    if ($PRINT) { open $output, ">$PRINT" } else { $output = $config->{LOG} }
606    my $print_rejected = sub {
607        my ($groups, $i, $rpm, $size, $install_cd) = @_;
608        # FIXME ugly hack to display more rejected in multigroups buildings because discFiles is per disc and not per group.
609        # $done{$groups->[$i]{urpm}{rpmkey}{rpm}{$rpm}} && ! ref $groups->[$i]{rejected}{$rpm} and return 1;
610        $done{$groups->[$i]{urpm}{rpmkey}{rpm}{$rpm}} and return 1;
611        $groups->[$i]{done}{rep}{$rpm} and return 1;
612        if ($groups->[$i]{brokendeps}{$rpm} == 2) {
613            ref $groups->[$i]{rejected}{$rpm} or print $output "ERROR printDiscsFile: this should not happen, rejected is not a table for $rpm (group $i)\n" and next;
614        }
615        printf $output "REJECTED master disc $install_cd %10d %s $rpm (", $size, $groups->[$i]{limit}{$rpm} ? "limit" : "";
616       
617        my $ref = $groups->[$i]{rejected}{$rpm};
618        if (ref $ref and %$ref) {
619            foreach my $l (keys %{$groups->[$i]{rejected}{$rpm}}) {
620                print $output " [ list $l ] ";
621                if (ref $groups->[$i]{rejected}{$rpm}{$l}) { 
622                    print $output join(',', map { "$config->{rejected_options}{$_->[0]}: $_->[1]" } @{$groups->[$i]{rejected}{$rpm}{$l}})
623                }
624            }
625        } else {
626            print $output "not selected"
627        }
628        print $output ")\n";
629        0
630    };
631    my %size;
632    # this is not really correct as multiple list may have packages with the same name but different size
633    if ($metagroups) {
634        foreach my $iogroups (@$metagroups) {
635            foreach (@$iogroups) {
636                my $groups = $_->[0];
637                for (my $i; $i < @$groups; $i++) {
638                    foreach my $rpm (keys %{$groups->[$i]{size}}) {
639                        foreach my $list (keys %{$groups->[$i]{size}{$rpm}}) { 
640                            $size{$rpm} = $groups->[$i]{size}{$rpm}{$list}[0] if $size{$rpm} < $groups->[$i]{size}{$rpm}{$list}[0] 
641                        }
642                    }
643                }
644            }
645        }
646    }
647    for (my $cd; $cd < @$discsFiles; $cd++) {
648        $discsFiles->[$cd] or next;
649        print $log "discsFiles: $cd\n";
650        my $cdname = $config->{disc}[$cd]{label};
651        foreach my $rep (keys %{$discsFiles->[$cd]}) {
652            foreach my $list (keys %{$discsFiles->[$cd]{$rep}}) {
653                if (!$metagroups) {
654                    foreach my $rpm (sort keys %{$discsFiles->[$cd]{$rep}{$list}}) {
655                        #$done{$rpm} = 1;
656                        #$rpm =~ /src$/ and next;
657                        printf $output "$cdname $rpm\n", $size{$rpm};
658                    }
659                } else {
660                    foreach my $rpm (sort { $size{$a} <=> $size{$b} } keys %{$discsFiles->[$cd]{$rep}{$list}}) {
661                        printf $output "$cdname %10d $rpm\n", $size{$rpm};
662                    }
663                }
664            }
665        }
666    }
667    if (!$metagroups) { $output = $config->{LOG} }
668    foreach my $iogroups (@$metagroups) {
669        foreach (@$iogroups) {
670            my $groups = $_->[0];
671            for (my $i; $i < @$groups; $i++) {
672                my $install_cd = "$config->{disc}[$groups->[$i]{installDisc}]{label} ($groups->[$i]{installDisc})";
673                if (ref $groups->[$i]{buildlist}) {
674                    foreach (sort { $groups->[$i]{limit}{$b} <=> $groups->[$i]{limit}{$a} } sort { $size{$a} <=> $size{$b} } @{$groups->[$i]{buildlist}}) {
675                        $print_rejected->($groups, $i, $_, $size{$_}, $install_cd) and next;
676                        $done{$groups->[$i]{urpm}{rpmkey}{rpm}{$_}} = 1
677                    }
678                }
679                foreach (sort { $size{$a} <=> $size{$b} } keys %{$groups->[$i]{urpm}{rpm}}) {
680                    $print_rejected->($groups, $i, $_, $size{$_}, $install_cd)
681                }
682            }
683        }
684    }
685}
686
687sub printBatchFile {
688    my ($config, $discsFiles, $PRINTSCRIPT) = @_;
689    # FIXME to please perl_checker
690    my $log = $config->{LOG}; 
691    if (-f $PRINTSCRIPT) {
692        my $err = unlink $PRINTSCRIPT;
693        if (!$err) { print $log "Unlinking failed $PRINTSCRIPT: $!\n"; return };
694    }
695    my $err = copy $config->{configfile}, $PRINTSCRIPT;
696    if (!$err) { print $log "Linking failed $PRINTSCRIPT: $!\n"; return };
697    open my $A, ">>$PRINTSCRIPT";
698    print $A "END\n";
699    for (my $cd; $cd < @$discsFiles; $cd++) {
700        $discsFiles->[$cd] or next;
701        print $log "discsFiles: $cd\n";
702        print $A "CD $cd\n";
703        foreach my $rep (keys %{$discsFiles->[$cd]}) {
704            print $A " REP $rep\n";
705            foreach my $list (keys %{$discsFiles->[$cd]{$rep}}) {
706                print $A "  LIST $list\n";
707                foreach my $rpm (keys %{$discsFiles->[$cd]{$rep}{$list}}) {
708                    $rpm and print $A "   $rpm $discsFiles->[$cd]{$rep}{$list}{$rpm}\n";
709                }
710            }
711        }
712    }
713}
714
715sub readBatchFile {
716    my ($file) = @_;
717    local *A; open A, $file or print "ERROR readBatchFile: could not open $file for reading\n" and return 0;
718    my @discsFiles;
719    my @cd;
720    while (<A>) { /^END/ and last }
721    my ($cd, $rep, $list);
722    while (<A>) {
723        if (/^CD (\d+)/) { $cd = $1; next }
724        if (/^ REP (\S+)/) { $rep = $1; next }
725        if (/^  LIST (\d+)/) { $list = $1; next }
726        if (/^   (\S+) (\S+)/) { 
727            $discsFiles[$cd]{$rep}{$list}{$1} = $2;
728            push @{$cd[$cd]{$rep}{$list}{$2}}, [ 1, "$1.rpm" ];
729            next 
730        }
731    }
732    return \@discsFiles, \@cd
733}
734
735sub config {
736    my ($file, $config, $functions, $mkcd) = @_;
737    my $log = $config->{LOG};
738    open my $F,$file or die "ERROR config: cannot open $file\n";
739    while (<$F>) { chomp; /^#/ or !$_ or last }
740    chomp;
741    $config->{name} = (split)[0];
742    my %vars;
743    my $match_val = q((?:([^"\s]+)|"([^\"]+)"));
744    my $match_val2 = q(((?:[^"\s]*(?:[^"\s]+|"[^\"]+")[^"\s]*)+));
745    my ($cd, $fn, $nk, $type, @todo, $discMax);
746    $config->{virtual_disc} = {};
747    my ($line, $a);
748    my ($key, $val);
749    $_ = $line;
750    while (<$F>) {
751        /^#/ and next;
752        chomp;
753        $_ or next;
754        s/#.*//;
755        my $b = s/\\\s*$//;
756        if ($a) {
757            $line .= $_
758        } else {
759            $line = $_ 
760        }
761        ($key, $val) = /([^=]+)=(.*)/ and $vars{$key} = $val;
762        foreach my $k (keys %vars) {
763            $line =~ s/\$$k/$vars{$k}/g
764        }
765        $a = $b;
766        $a and next;
767        local $_ = $line;
768        if (/^list (.*)/) {
769                my $line = $1;
770                my @args;
771                while ($line =~ s/$match_val2//) { my $a = $1; $a =~ s/"//g; push @args, $a }
772                #print "config: args (" . ( join ' | ', @args) . ")\n";
773                my $todo = parseCommandLine("list", \@args, $functions->{list});
774                $cd = $todo->[0][1][0];
775                #print "config: list $cd (@{$todo->[0][1]})\n";
776                if (!$config->{list}[$cd]) {
777                    @args and usage('list', $functions->{list}, "list $cd, list definition (@args) too many arguments");
778                    foreach (@$todo) {
779                        log_("$_->[2]\n", $config->{verbose}, $log, 3);
780                        if (!&{$_->[0]}($cd, @{$_->[1]})) { log_("ERROR: $_->[2]\n", $config->{verbose}, $log); $nk = 1 }
781                    }
782                    $type = 1;
783                    $fn = 0
784                } else {
785                    $type = 0;
786                    log_("ERROR config: list $cd already defined, ignoring\n", $config->{verbose}, $log);
787                }
788            # FIXME keep for compatibility
789        } elsif (/^LIST /) {
790            if (/^LIST (\d+)(?:\s+(\S.*))*/) {
791                $cd = $1;
792                push @{$config->{list}[$cd]{filelist}},  (split ' ',$2) if $2;
793                $type = 1;
794                log_("LIST $1 $2\n", $config->{verbose}, $log, 3)
795            } else {
796                $nk = 1;
797                log_("WARNING: LIST syntax error ($_)\n", $config->{verbose}, $log);
798                log_("         LIST <list number> <file list 1> <file list 2> ... <file list n>\n", $config->{verbose}, $log)
799            }
800        } elsif (/^disc (.*)/) {
801                my $line = $1;
802                my @args;
803                while ($line =~ s/$match_val2//) { my $a = $1; $a =~ s/"//g; push @args, $a }
804                #print "config: args (" . ( join ' | ', @args) . ")\n";
805                my $todo = parseCommandLine("disc", \@args, $functions->{disc});
806                $cd = $todo->[0][1][0];
807                #print "config: disc $cd (@{$todo->[0][1]})\n";
808                if (!$config->{disc}[$cd]) {
809                    @args and usage('disc', $functions->{disc}, "disc $cd, disc definition (@args) too many arguments");
810                    foreach (@$todo) {
811                        log_("$_->[2]\n", $config->{verbose}, $log, 3);
812                        if (!&{$_->[0]}($cd, @{$_->[1]})) { log_("ERROR: $_->[2]\n", $config->{verbose}, $log); $nk = 1 }
813                    }
814                    $type = 2;
815                    $fn = 0
816                } else {
817                    $type = 0;
818                    log_("ERROR config: disc $cd already defined, ignoring\n", $config->{verbose}, $log);
819                }
820            # FIXME keep for compatibility
821        } elsif (/^DISC (.*)/) {
822            if (/^DISC (\d+)\s+(\d+)\s+$match_val(?:\s+DISC\s+(\d+))?\s+$match_val(?:\s+$match_val)?/) { 
823                #print "1($1) 2($2) 3($3) 4($4) 5($5) 6($6) 7($7) 8($8) 8($9)\n";
824                $config->{disc}[$1]{size} = $2;
825                my $disc = $config->{disc}[$1];
826                $disc->{serial} = substr "$3$4", 0, 128;
827                $disc->{name} = $5;
828                $disc->{longname} = "$6$7";
829                $disc->{appname} = substr("$6$7", 0, 128);
830                $disc->{label} = substr(("$6$7" ? "$8$9" : "$6$7"), 0, 32);
831                $cd = $1;
832                $type = 2;
833                $fn = 0;
834                $4 > $discMax and $discMax = $4;
835                log_("DISC $1 $2 $3$4 $5 $6$7 $8$9\n", $config->{verbose}, $log)
836            } else {
837                $nk = 1;
838                $type = 0;
839                log_("WARNING: DISC syntax error ($_)\n", $config->{verbose}, $log);
840                log_("         DISC <cd number> <cd size> <cd serial name> DISC <real cd number> <disc name>\n", $config->{verbose}, $log)
841            }
842        } elsif (/^END/) {
843            last       
844        } else {
845            my @args;
846            while (s/$match_val2//) { my $a = $1; $a =~ s/^"|"$//g; push @args, $a }
847            my $prog = shift @args;
848            log_("config: function $prog(" . join(' | ',@args) . ")\n", $config->{verbose}, $log,4);
849            $type == 1 and do {
850                if ($prog ne 'rpmlist') {
851                    push @{$config->{list}[$cd]{packages}}, { rpm => [ $prog ] , srpm => \@args } 
852                } else {
853                    push @todo, [ $prog, \@args, $cd, $fn ];
854                    $fn++;
855                }
856                next
857            };
858            $type == 2 and do {
859                push @todo, [$prog, \@args, $cd, $fn];
860                $fn++;
861                next
862            }
863        }
864    }
865    $config->{configfile} = $file;
866    $config->{discMax} = $discMax;
867    foreach (@todo) {
868        my ($prog, $args, $cd, $fn) = @$_;
869        if ($functions->{$prog}) {
870            log_("FUNCTION $prog (@$args)\n", $config->{verbose}, $log,5);
871            my $todo = parseCommandLine($prog, $args, $functions->{$prog});
872            @$args and usage($prog, $functions->{$prog}, "disc $cd, function $fn, @$args, too many arguments");
873            foreach (@$todo) {
874                log_("config: todo $_->[2]\n", $config->{verbose}, $log, 4);
875                if (!&{$_->[0]}($cd, $fn, @{$_->[1]})) { log_("ERROR: $_->[2]\n", $config->{verbose}, $log); $nk = 1 }
876            }
877        } else {
878            usage($prog, $mkcd->{config}, "disc $cd, function $fn, '$prog' command does not exist");
879        }
880    }
881    $nk and return 0;
882    #printTable($config);
883    1
884}
885
886sub compute_files_md5 {
887    my ($md5file, $files) = @_;
888    open my $MD5, ">$md5file";
889    my $text;
890    foreach (@$files) {
891        my $md5 = new Digest::MD5;
892        open my $F, $_ or die "FATAL: Could not open $_\n";
893        $md5->addfile($F);
894        my $digest = $md5->hexdigest;
895        $text .= "$digest  $1\n" if m,([^/]+)$,
896    }
897    print $MD5 $text;
898    close $MD5
899}
900
901sub compute_md5 {
902    my ($to_check, $ignore) = @_;
903    my @files;
904    md5_add_tree($to_check, \@files, $ignore);
905    my $md5 = new Digest::MD5;
906    foreach (sort { $a->[0] cmp $b->[0] } @files) {
907        my $f = $_->[1];
908        open my $A, $f;
909        $md5->addfile($A);
910        #my $tmpmd5 = new Digest::MD5;
911        #local *A, open A, $f;
912        #$tmpmd5->addfile(*A);
913        #print "MD5: $_->[0] (", $tmpmd5->hexdigest() ,")\n";
914    }
915    my $digest = $md5->hexdigest;
916    # print "IGNORE " , join " ",keys %$ignore ,"\n";
917    return $digest
918}
919
920sub md5_add_tree {
921    my ($to_check, $files, $ignore) = @_;
922    foreach (@$to_check) {
923        my ($dest, $f) = @$_;
924        $f =~ m|/?\.{1,2}$| and next;
925        $f =~ /~$/ and next;
926        $f =~ s|//+|/|g;
927        $dest =~ s|//+|/|g;
928        $ignore->{$dest} and next;
929        if (-d $f) {
930            md5_add_tree([ map { [ "$dest/$_", "$f/$_" ] } all $f ], $files, $ignore)
931        } else {
932            push @$files, [ $dest, $f ]
933        }
934    }
935}
936
937sub log_ {
938    my ($msg, $verbose, $log, $level) = @_;
939    return if $level > $verbose;
940    my $LOG;
941    if (!$log) { open $LOG, ">&STDERR" } else { $LOG = $log }
942    my $leak_search;
943    #if ($level <= -1 ){
944    #   $leak_search = "[" . (split ' ', cat_("/proc/$$/stat"))[22]/1024 . "] ";
945    #}
946    print $LOG "$leak_search$msg";
947}
948
949# TODO must add some check of maximum authorized size
950sub include_md5 {
951    my ($iso, $write, $verbose) = @_;
952    my $ISO; 
953    if ($write) {
954        open $ISO, "+<$iso" or return "ERROR include_md5: unable to open $iso ($!)\n"; 
955    } else {
956        open $ISO, $iso or return "ERROR include_md5: unable to open $iso ($!)\n";     
957    }
958    binmode $ISO;
959    my $offset = 16*2048;
960    # blank header
961    seek $ISO, $offset, 0;
962    my ($buf, $msg);
963    while (1) {
964        read $ISO,$buf,2048;
965        my $c = ord $buf;
966        last if $c == 1;
967        return "ERROR include_md5: could not find primary volume descriptor\n" if $c == 255;
968        $offset += 2048
969    }
970    my $size = ((ord substr $buf, $SIZE_OFFSET, 1) * 0x1000000 + 
971                (ord substr $buf, $SIZE_OFFSET + 1, 1) * 0x10000 + 
972                (ord substr $buf, $SIZE_OFFSET + 2, 1) * 0x100 + 
973                (ord substr $buf, $SIZE_OFFSET + 3, 1)) * 2048;
974    my ($system, $volume, $publisher, $prep, $app) = map { $a = $_ ; $a =~ s/^\s*//; $a =~ s/\s*$//; $a } (substr($buf, 8, 22), substr($buf, 30, 40), substr($buf, 318, 128), substr($buf, 446, 32), substr($buf, 574, 128)); 
975    print "include_md5:\nSystem: \t$system\nVolume: \t$volume\nPublisher: \t$publisher\nData preparer: \t$prep\nApplication: \t$app\nISO size: \t$size\n" if $verbose;
976    seek $ISO, $offset + $INFO_OFFSET, 0;
977    read $ISO, $buf,512;
978    my ($md5sum) = $buf =~ /.md5 = (\S+)/;
979    $msg .= "include_md5: previous data $buf\n";
980    seek $ISO, 0, 0;
981    my $md5 = new Digest::MD5;
982    my $read = read $ISO, $buf, $offset + $INFO_OFFSET;
983    $md5->add($buf);
984    seek $ISO, 512, 1;
985    $read += 512;
986    $|=1;
987    my $val = int $size/2048/100;
988    $verbose and print "\rReading: 0 %";
989    my ($i, $j);
990    # skip last $SKIP bytes that sometimes are not correctly burned by some drives
991    my $n = 1;
992    while ($n && $read < $size - $SKIP * 2048) {
993        $n = read $ISO, $buf,2048;
994        print "\rReading: ", $j++, " %" if ($verbose && !($i++ % $val));
995        $md5->add($buf);
996        $read += $n;
997    }
998    print "\n";
999    my $digest = $md5->hexdigest;
1000    $msg .= "include_md5: computed md5 $digest\n";
1001    my $res = $md5sum eq $digest;
1002    if ($md5sum) {
1003        $msg .= "include_md5: previous md5 $md5sum\ninclude_md5: md5sum check ";
1004        $msg .= $res ? "OK\n" : "FAILED\n"
1005    }
1006    print $msg if $verbose;
1007    $write or return $res;
1008    seek $ISO, $offset + $INFO_OFFSET, 0;
1009    my $str = substr "$volume.md5 = $digest", 0, 512;
1010    my $l = length $str;
1011    print $ISO ($l > 512 ? substr $str, -1, 512 : $str . ' ' x (512 - $l));
1012    close $ISO
1013}
1014
1015sub convert_size {
1016    my ($size, $default, $LOG) = @_;
1017    if ($size =~ /[\d.]+g$/i) {
1018        $size = $size * $GB;
1019    } elsif ($size =~ /[\d+.]+m$/i) {
1020        $size = $size * $MB;
1021    } elsif ($size =~ /[\d+.]+k$/i) {
1022        $size = $size * $KB;
1023    } elsif ($size !~ /[\d+.]+$/i) {
1024        log_("ERROR disc: $size is invalid, using default ($default)\n",1,$LOG);
1025        $size = $default;
1026    }                   
1027   $size 
1028}
1029
1030sub fix_dir {
1031    chomp(my $pwd = `pwd`);
1032    return map { m,^/, or $_ = "$pwd/$_"; $_ } @_
1033}
1034
1035sub find_list {
1036    my ($config, $group, $r, $list, $notdone, $needed) = @_;
1037    my $l;
1038    my @all;
1039    foreach (keys %{$group->{size}{$r}}) {
1040        log_("find_list: for $r trying list $_ needed $needed (listmatrix $l - $_ -> $group->{listmatrix}{rpm}{$l}{$_} listmatrix $list - $_ -> $group->{listmatrix}{rpm}{$list}{$_})\n",$config->{verbose}, $config->{LOG}, 11);
1041        if (
1042            (
1043                ($l && 
1044                    ($group->{listmatrix}{rpm}{$l}{$_} && $group->{listmatrix}{rpm}{$_}{$l} && $group->{listmatrix}{rpm}{$l}{$_} < $group->{listmatrix}{rpm}{$_}{$l})
1045                    ||
1046                    ($group->{listmatrix}{rpm}{$l}{$_} && !$group->{listmatrix}{rpm}{$_}{$l})
1047                ) || 
1048                (!$l && 
1049                    (!$list
1050                       || ($needed && $group->{listmatrix}{rpm}{$list}{$_} && $group->{listmatrix}{rpm}{$list}{$_} <= $needed
1051                           || 
1052                           !$needed && $group->{listmatrix}{rpm}{$list}{$_})
1053                    )
1054                )
1055            )
1056            && ($notdone && !$config->{list}[$_]{done} || !$notdone)) {
1057            $l = $_;
1058            unshift @all, $_
1059        } elsif ($group->{listmatrix}{rpm}{$list}{$_}) {
1060            push @all, $_
1061        }
1062    }
1063    return $l, \@all
1064}
1065
10661
1067
1068#
1069# Changelog
1070#
1071# 2002 02 27
1072# make the locale constraint free on the right for cleanrpmsrate locale addition (kde-i18n-zh_BG and such)
1073#
1074# 2002 03 03
1075# fix typo in checkdiscs
1076#
1077# 2002 03 04
1078# fix checkcds pb with check[0] used.
1079#
1080# 2002 03 07
1081# add possibility to remove package from rpmsrate
1082#
1083# 2002 03 12
1084# add all .*kernel- in rpmsrate
1085#
1086# 2002 03 17
1087# add serial name instead of cdnumber when name is not know
1088#
1089# 2002 05 07
1090# add check_discs, compute_md5, write_graft, md5_add_tree
1091#
1092# 2002 05 22
1093# fix a pb in md5
1094#
1095# 2002 05 25
1096# add log function
1097#
1098# 2002 06 05
1099# fix md5 for isolinux
1100#
1101# 2002 08 12
1102# fix/change cleanrpmsrate
1103#
1104# 2002 09 04
1105# do not open for writing iso file in include_md5 if not in write mode
1106#
1107# 2002 09 25
1108# add completion feedback to include_md5
1109#
1110# 2004 05 28
1111# move find_list to tools as it is used in both Build and List
Note: See TracBrowser for help on using the repository browser.