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