source: soft/build_system/build_system/mkcd/branches/Corpo_2_1/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: 29.3 KB
Line 
1package Mkcd::Tools;
2
3our $VERSION = '0.5.5';
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);
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);
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 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) { my $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) { my $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 instal 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\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 = "$tops[0]/Mandrake/base/depslist.ordered";
349    -f $depslist or print "ERROR: could not find depslist $depslist file\n" and return 0;
350    my $hdlists = "$top/Mandrake/base/hdlists";
351    open my $A, $hdlists or die "unable to open $hdlists";
352    my @hdlist = 0;
353    my @discsFiles;
354    my @check = 0;
355    while (<$A>) {
356        my ($hdlist, $dir, undef) = split;
357        my ($hdid) = $hdlist =~ /(\d*).cz/;
358        my $hdfile = "$tops[0]/Mandrake/base/$hdlist";
359        push @hdlist, $hdfile;
360        push @check, [[ $hdid, $dir, 1 ]];
361        -f $hdfile or print "ERROR: could not find $hdfile file\n" and return 0;
362        print "Reading $top/$dir\n";
363        my $C;
364        if (! opendir $C, "$top/$dir") {
365            foreach (@tops) {
366                opendir $C, "$_/$dir" or next;
367                last
368            }
369        }
370        foreach (readdir $C) {
371            /(.*)\.rpm/ or next;
372            $discsFiles[$hdid]{$dir}{1}{$1} = 1
373        }
374
375    }
376    checkDiscs(\@hdlist, $depslist, \@discsFiles, \@check)
377}
378
379#
380# regexp version
381#
382sub cleanrpmsrate2 {
383    my ($rpmsrate, @rpms) = @_;
384    my $LOG; open $LOG, ">&STDERR";
385    my @rpm;
386    foreach (@rpms) {
387        -d $_ or print $LOG "ERROR: $_ is not a directory\n" and next;
388        opendir my $A, $_;
389        push @rpm, grep { s/-[^-]+-[^-]+\.[^.]+\.rpm// } all $A;
390    }
391    my %done;
392    my (@flags, @c);
393    my ($mod, $text, $prev, $rate, $current);
394    my (%rate, %section);
395    open my $A, $rpmsrate or print $LOG "ERROR: cannot open $rpmsrate\n";
396    while (<$A>) {
397        s/#.*//;
398        /^\s*$/ and $text .= "\n" and next;
399        if (/^(\S+)/) {
400            $text .= "$1\n";
401            $current = $1;
402            @flags = $current;
403            next
404        }
405        my ($indent, $r, $flags, $data) = /^(\s*)([1-5]?)((?:\s+(?:(?:!\s*)?[0-9A-Z_]+(?:"[^"]*")?(?:\s+(?:\|\|\s+)?)*)+\s+)|\s+)(.*)$/;
406        if ($r) {
407            $rate = $r
408        } elsif ($prev) {
409            chop $indent;
410            $r = $prev
411        }
412        push @flags, split ' ', $flags; 
413        $data or $text .= "$indent$r$flags" and next;
414        my ($postfix) = $data =~ /(\s*)$/;
415        my @k;
416        foreach my $n (split ' ', $data) {
417            @c = grep { /^$n$/ } @rpm;
418            map { if ((!$done{$_}[1] || $current eq "INSTALL") && $done{$_}[0] ne $current) { push @k, $_; @{$done{$_}} = @flags } } @c
419        } 
420        if (@k) { $text .= "$indent$r$flags@k$postfix\n"; $prev = '' } else { $prev = $r };
421        @rate{@k} = ($rate) x @k;
422        push @{$section{$current}}, @k
423    }
424    close A;
425    if (@rpms) {
426        if (open A, ">$rpmsrate") {
427            print A $text;
428            close A
429        } else {
430            @rpms and print $LOG "ERROR: cannot open $rpmsrate for writing\n";
431            print $text
432        }
433    }
434    [\%rate, \%section, \%done];
435}
436
437
438sub cleanrpmsrate {
439    my ($rpmsrate, $output, $norpmsrate, $reprpms) = @_;
440    $norpmsrate ||= [];
441    my $LOG; open $LOG, ">&STDERR";
442    open my $A, $rpmsrate or print $LOG "ERROR: cannot open $rpmsrate\n";
443    my (@rpmsrate, %potloc);
444    # must preread to get locale guessed packages
445    # postfix is just used not to break the diff when checking if the result is correct
446    while (<$A>) {
447        chomp;
448        s/#.*//;
449        #s/\s*$//;
450        /^(\s*)$/ and push @rpmsrate, [ '', 0, '', [] ] and next;
451        if (/^(\S+)(.*)$/) {
452            push @rpmsrate, [ 0, 0, $1, [], $2 ];
453            next
454        }
455        if (/^(\s*)([1-5])?(\s?[0-9A-Z_]+)$/) {
456            push @rpmsrate, [ $1, $2, $3, [] ];
457            next
458        }
459        my ($indent, $r, $flags, $data) = /^(\s*)([1-5])?(\s*(?:(?:(?:!\s*)?[0-9A-Z_]+(?:"[^"]*")?(?:\s+(?:\|\|\s+)?)*)+\s+)|\s*)(.*)$/;
460        my ($postfix) = $data =~ /(\s*)$/;
461        my @data;
462        my $i;
463        foreach ([$data =~ /(?:^|\s)(\S+)-(?:\S+)\s+\1-(?:\S+)(?:\s|$)/g], [split ' ', $data]) {
464            $data[$i++] = [ @$norpmsrate ? any { my $r = $_; $r if !any { $r =~ /$_/ } @$norpmsrate } @$_ : @$_ ]
465        }
466        $potloc{$_} = [] foreach  @{$data[0]};
467        push @rpmsrate, [ $indent,$r, $flags, $data[1], $postfix ];
468    }
469    my (%rpms, $text);
470    my (%rate, %section, %keyword);
471    my (%locale, %localized_pkg);
472    my $kernel_like = "((?:(?:NVIDIA_)?kernel.*)|NVIDIA_nforce.*|cm2020.*)";
473    my $urpm = new URPM;
474    foreach my $dir (keys %$reprpms) {
475        foreach (@{$reprpms->{$dir}}) { 
476            my $rpm = "$_.rpm";
477            s/-[^-]+-[^-]+\.[^.]+$// or next;
478            any { $rpm =~ /$_/ } @$norpmsrate and next;
479            if (/(.*?)([_-]*[\d._]*)-devel$/ || /$kernel_like(-[^.]+(?:\.[^.]+){3,5}mdk)$/) { 
480                if (!$rpms{$1}) { $rpms{$1} = $2 }
481                elsif (URPM::ranges_overlap("== $2", "> $rpms{$1}")) { $rpms{$1} = $2 }
482            } elsif (my ($pg, $loc) = /^(.*)-([^-+]+)$/) {
483                if ($potloc{$pg}) {
484                    my $id = $urpm->parse_rpm("$dir/$rpm");
485                    my $pkg = $urpm->{depslist}[$id] or print "ERROR cleanrpmsrate: parse_rpm $dir/$rpm failed\n" and next;
486                    # some i18n packages does not require the same locale, e.g. kde-i18n-nb and nn requires locales-no
487                    # if (grep { s/locales-// && $loc =~ /^$_(_|$)/ } @{$header{REQUIRENAME}}) {
488                    if (any { /^locales-..$/ } $pkg->requires) {
489                        push @{$locale{$pg}}, $loc;
490                        $localized_pkg{"$pg-$loc"} = 1
491                    }
492                }
493            }
494        }
495    }
496    my (%done, @flags, $prev, @tree_rate, $prev_level);
497    foreach (@rpmsrate) {
498        if (!$_->[0]) {
499            $text .= "$_->[2]$_->[4]\n";
500            if ($_->[2]) {
501                @flags = $_->[2]
502            }
503            next
504        }
505        my ($indent, $r, $flags, $data, $postfix) = @$_;
506        my $level = (length $indent)/2 - 1;
507        my $rate;
508        if ($r) {
509            #print "tree_rate[$level] = $r\n";
510            $rate = $r;
511            $tree_rate[$level] = $r
512        } else {
513            if (@$data) {
514                if ($level > $prev_level) {
515                    $level-- 
516                } else {
517                    # fix a syntax error in rpmsrate such as
518                    # A
519                    #   1 toto
520                    #   B tata <---
521                    #     4 titi
522                    @$data = ()
523                }
524            }
525            $rate = $tree_rate[$level];
526        }
527        $prev_level = $level;
528        @flags = @flags[0 .. $level];
529        push @flags, grep { s/\s//; !/(\|\||[A-Z_]+"[^"]+")/ } split(' ', $flags);
530        my $flat_path = join ' ', @flags;
531        if (!@$data) { $text .= "$indent$r$flags$postfix\n"; next }
532        my @k;
533        foreach (@$data) {
534            my $c = $_;
535            if ($done{$_} eq $flat_path) { next }
536            my ($d) = /(.*)-[^-]+/;
537            my ($a, $b); 
538            if (($flags[0] ne "INSTALL" && s/(-devel)// ? ($b = "-devel") : /^$kernel_like/) && ($rpms{$_} || (defined $rpms{"lib$_"} and $a = "lib") || (defined $rpms{"lib64$_"} and $a = "lib64"))) { 
539                my $d = "$a$_" . $rpms{"$a$_"} . $b; 
540                $keyword{$c} = $d; 
541                if (!$done{$d} || $flags[0] eq "INSTALL") { $done{$d} = $flat_path; push @k, $d }
542            }
543            if ($locale{$d} && $localized_pkg{$c}) {
544                foreach (sort @{$locale{$d}}) {
545                    next if $done{"$d-$_"} eq $flat_path;
546                    $done{"$d-$_"} = $flat_path; 
547                    push @k , "$d-$_"
548                }
549                next
550            }
551            push @k, $c;
552            $done{$c} = $flat_path
553        } 
554        if (@k) { $text .= "$indent$r$flags@k$postfix\n" }
555        @rate{@k} = ($rate) x @k;
556        my $path;
557        foreach (@flags) {
558            $path .= $path ? "/$_" : $_;
559            push @{$section{$path}}, @k
560        }
561    }
562    if (%rpms || $output) {
563        if (%$reprpms || $output) {
564            $output ||= $rpmsrate;
565            if (open A, ">$output") { 
566                print A $text;
567                close A
568            } else { 
569                print $LOG "ERROR cleanrpmsrate: cannot open $rpmsrate for writing\n";
570                print $text
571            }
572        }
573    }
574    [\%rate, \%section, \%keyword]
575}
576
577sub imageSize {
578    my ($file) = @_;
579    my ($width, $height, $err) = imgsize $file;
580
581    return (defined $width ?
582    [ $width, $height ] :
583    "error: $err")
584}
585
586sub printDiscsFile {
587    my ($config, $discsFiles, $PRINT, $metagroups) = @_;
588    my (%done, $a);
589    my $log = $config->{LOG};
590    if ($PRINT) { open $a, ">$PRINT" } else { $a = $config->{LOG} }
591    my $print_rejected = sub {
592        my ($groups, $i, $rpm) = @_;
593        # FIXME ugly hack to display more rejected in multigroups buildings because discFiles is per disc and not per group.
594        # $done{$groups->[$i]{urpm}{rpmkey}{rpm}{$rpm}} && ! ref $groups->[$i]{rejected}{$rpm} and return 1;
595        $done{$groups->[$i]{urpm}{rpmkey}{rpm}{$rpm}} and return 1;
596        $groups->[$i]{done}{$rpm} and return 1;
597        if ($groups->[$i]{brokendeps}{$rpm} == 2) {
598            ref $groups->[$i]{rejected}{$rpm} or print $a "ERROR printDiscsFile: this should not happen, rejected is not a table for $rpm (group $i)\n" and next;
599        }
600        print $a "REJECTED master disc $groups->[$i]{installDisc} $rpm (";
601        if (ref $groups->[$i]{rejected}{$rpm}) { 
602            print $a join(',', map { "$config->{rejected_options}{$_->[0]}: $_->[1]" } @{$groups->[$i]{rejected}{$rpm}})
603        } else {
604            print $a "not selected"
605        }
606        print $a ")\n";
607        0
608    };
609    for (my $cd; $cd < @$discsFiles; $cd++) {
610        $discsFiles->[$cd] or next;
611        print $log "discsFiles: $cd\n";
612        my $cdname = $config->{disc}[$cd]{label};
613        foreach my $rep (keys %{$discsFiles->[$cd]}) {
614            foreach my $list (keys %{$discsFiles->[$cd]{$rep}}) {
615                foreach my $rpm (sort keys %{$discsFiles->[$cd]{$rep}{$list}}) {
616                    #$done{$rpm} = 1;
617                    #$rpm =~ /src$/ and next;
618                    print $a "$cdname $rpm\n";
619                }
620            }
621        }
622    }
623    if (!$metagroups) { $a = $config->{LOG} }
624    foreach (@$metagroups) {
625        my $groups = $_->[0];
626        for (my $i; $i < @$groups; $i++) {
627            if (ref $groups->[$i]{buildlist}) {
628                foreach (sort @{$groups->[$i]{buildlist}}) {
629                    $print_rejected->($groups,$i,$_) and next;
630                    $done{$groups->[$i]{urpm}{rpmkey}{rpm}{$_}} = 1
631                }
632            }
633            foreach (sort keys %{$groups->[$i]{urpm}{rpm}}) {
634                $print_rejected->($groups,$i,$_)
635            }
636        }
637    }
638}
639
640sub printBatchFile {
641    my ($config, $discsFiles, $PRINTSCRIPT) = @_;
642    # FIXME to please perl_checker
643    my $log = $config->{LOG}; 
644    if (-f $PRINTSCRIPT) {
645        my $err = unlink $PRINTSCRIPT;
646        if (!$err) { print $log "Unlinking failed $PRINTSCRIPT: $!\n"; return };
647    }
648    my $err = copy $config->{configfile}, $PRINTSCRIPT;
649    if (!$err) { print $log "Linking failed $PRINTSCRIPT: $!\n"; return };
650    open my $A, ">>$PRINTSCRIPT";
651    print $A "END\n";
652    for (my $cd; $cd < @$discsFiles; $cd++) {
653        $discsFiles->[$cd] or next;
654        print $log "discsFiles: $cd\n";
655        print $A "CD $cd\n";
656        foreach my $rep (keys %{$discsFiles->[$cd]}) {
657            print $A " REP $rep\n";
658            foreach my $list (keys %{$discsFiles->[$cd]{$rep}}) {
659                print $A "  LIST $list\n";
660                foreach my $rpm (keys %{$discsFiles->[$cd]{$rep}{$list}}) {
661                    $rpm and print $A "   $rpm $discsFiles->[$cd]{$rep}{$list}{$rpm}\n";
662                }
663            }
664        }
665    }
666}
667
668sub readBatchFile {
669    my ($file) = @_;
670    local *A; open A, $file or print "ERROR readBatchFile: could not open $file for reading\n" and return 0;
671    my @discsFiles;
672    my @cd;
673    while (<A>) { /^END/ and last }
674    my ($cd, $rep, $list);
675    while (<A>) {
676        if (/^CD (\d+)/) { $cd = $1; next }
677        if (/^ REP (\S+)/) { $rep = $1; next }
678        if (/^  LIST (\d+)/) { $list = $1; next }
679        if (/^   (\S+) (\S+)/) { 
680            $discsFiles[$cd]{$rep}{$list}{$1} = $2;
681            push @{$cd[$cd]{$rep}{$list}{$2}}, [ 1, "$1.rpm" ];
682            next 
683        }
684    }
685    return \@discsFiles, \@cd
686}
687
688sub config {
689    my ($file, $config, $functions) = @_;
690    my $log = $config->{LOG};
691    open F,$file or die "ERROR config: cannot open $file\n";
692    while (<F>) { chomp; /^#/ or !$_ or last }
693    chomp;
694    $config->{name} = (split)[0];
695    my $match_val = q((?:([^"\s]+)|"([^\"]+)"));
696    my $match_val2 = q(((?:[^"\s]*(?:[^"\s]+|"[^\"]+")[^"\s]*)+));
697    my ($cd, $fn, $nk, $type, @todo, $discMax);
698    $config->{virtual_disc} = [];
699    while (<F>) {
700        /^#/ and next;
701        chomp;
702        $_ or next;
703        s/#.*//;
704        if (/^list (.*)/) {
705                my $line = $1;
706                my @args;
707                while ($line =~ s/$match_val2//) { my $a = $1; $a =~ s/"//g; push @args, $a }
708                #print "config: args (" . ( join ' | ', @args) . ")\n";
709                my $todo = parseCommandLine("list", \@args, $functions->{list});
710                $cd = $todo->[0][1][0];
711                #print "config: list $cd (@{$todo->[0][1]})\n";
712                if (!$config->{list}[$cd]) {
713                    @args and usage('list', $functions->{list}, "list $cd, list definition (@args) too many arguments");
714                    foreach (@$todo) {
715                        log_("$_->[2]\n", $config->{verbose}, $log, 3);
716                        if (!&{$_->[0]}($cd, @{$_->[1]})) { log_("ERROR: $_->[2]\n", $config->{verbose}, $log); $nk = 1 }
717                    }
718                    $type = 1;
719                    $fn = 0
720                } else {
721                    $type = 0;
722                    log_("ERROR config: list $cd already defined, ignoring\n", $config->{verbose}, $log);
723                }
724            # FIXME keep for compatibility
725        } elsif (/^LIST /) {
726            if (/^LIST (\d+)(?:\s+(\S.*))*/) {
727                $cd = $1;
728                push @{$config->{list}[$cd]{filelist}},  (split ' ',$2) if $2;
729                $type = 1;
730                log_("LIST $1 $2\n", $config->{verbose}, $log, 3)
731            } else {
732                $nk = 1;
733                log_("WARNING: LIST syntax error ($_)\n", $config->{verbose}, $log);
734                log_("         LIST <list number> <file list 1> <file list 2> ... <file list n>\n", $config->{verbose}, $log)
735            }
736        } elsif (/^disc (.*)/) {
737                my $line = $1;
738                my @args;
739                while ($line =~ s/$match_val2//) { my $a = $1; $a =~ s/"//g; push @args, $a }
740                #print "config: args (" . ( join ' | ', @args) . ")\n";
741                my $todo = parseCommandLine("disc", \@args, $functions->{disc});
742                $cd = $todo->[0][1][0];
743                #print "config: disc $cd (@{$todo->[0][1]})\n";
744                if (!$config->{disc}[$cd]) {
745                    @args and usage('disc', $functions->{disc}, "disc $cd, disc definition (@args) too many arguments");
746                    foreach (@$todo) {
747                        log_("$_->[2]\n", $config->{verbose}, $log, 3);
748                        if (!&{$_->[0]}($cd, @{$_->[1]})) { log_("ERROR: $_->[2]\n", $config->{verbose}, $log); $nk = 1 }
749                    }
750                    $type = 2;
751                    $fn = 0
752                } else {
753                    $type = 0;
754                    log_("ERROR config: disc $cd already defined, ignoring\n", $config->{verbose}, $log);
755                }
756            # FIXME keep for compatibility
757        } elsif (/^DISC (.*)/) {
758            if (/^DISC (\d+)\s+(\d+)\s+$match_val(?:\s+DISC\s+(\d+))?\s+$match_val(?:\s+$match_val)?/) { 
759                #print "1($1) 2($2) 3($3) 4($4) 5($5) 6($6) 7($7) 8($8) 8($9)\n";
760                $config->{disc}[$1]{size} = $2;
761                my $disc = $config->{disc}[$1];
762                $disc->{serial} = substr "$3$4", 0, 128;
763                $disc->{name} = $5;
764                $disc->{longname} = "$6$7";
765                $disc->{appname} = substr("$6$7", 0, 128);
766                $disc->{label} = substr(("$6$7" ? "$8$9" : "$6$7"), 0, 32);
767                $cd = $1;
768                $type = 2;
769                $fn = 0;
770                $4 > $discMax and $discMax = $4;
771                log_("DISC $1 $2 $3$4 $5 $6$7 $8$9\n", $config->{verbose}, $log)
772            } else {
773                $nk = 1;
774                $type = 0;
775                log_("WARNING: DISC syntax error ($_)\n", $config->{verbose}, $log);
776                log_("         DISC <cd number> <cd size> <cd serial name> DISC <real cd number> <disc name>\n", $config->{verbose}, $log)
777            }
778        } elsif (/^END/) {
779            last       
780        } else {
781            my @args;
782            while (s/$match_val2//) { my $a = $1; $a =~ s/"//g; push @args, $a }
783            my $prog = shift @args;
784            log_("config: function $prog(" . join(' | ',@args) . ")\n", $config->{verbose}, $log,4);
785            $type == 1 and do {
786                if ($prog ne 'rpmlist') {
787                    push @{$config->{list}[$cd]{packages}}, { rpm => [ $prog ] , srpm => \@args } 
788                } else {
789                    push @todo, [ $prog, \@args, $cd, $fn ];
790                    $fn++;
791                }
792                next
793            };
794            $type == 2 and do {
795                push @todo, [$prog, \@args, $cd, $fn];
796                $fn++;
797                next
798            }
799        }
800    }
801    $config->{configfile} = $file;
802    $config->{discMax} = $discMax;
803    foreach (@todo) {
804        my ($prog, $args, $cd, $fn) = @$_;
805        if ($functions->{$prog}) {
806            log_("FUNCTION $prog (@$args)\n", $config->{verbose}, $log,5);
807            my $todo = parseCommandLine($prog, $args, $functions->{$prog});
808            @$args and usage($prog, $functions->{$prog}, "disc $cd, function $fn, @$args, too many arguments");
809            foreach (@$todo) {
810                log_("config: todo $_->[2]\n", $config->{verbose}, $log, 4);
811                if (!&{$_->[0]}($cd, $fn, @{$_->[1]})) { log_("ERROR: $_->[2]\n", $config->{verbose}, $log); $nk = 1 }
812            }
813        }
814    }
815    $nk and return 0;
816    #printTable($config);
817    1
818}
819
820sub compute_files_md5 {
821    my ($md5file, $files) = @_;
822    open my $MD5, ">$md5file";
823    my $text;
824    foreach (@$files) {
825        my $md5 = new Digest::MD5;
826        open my $F, $_ or die "FATAL: Could not open $_\n";
827        $md5->addfile($F);
828        my $digest = $md5->hexdigest;
829        $text .= "$digest  $1\n" if m,([^/]+)$,
830    }
831    print $MD5 $text;
832    close $MD5
833}
834
835sub compute_md5 {
836    my ($to_check, $ignore) = @_;
837    my @files;
838    md5_add_tree($to_check, \@files, $ignore);
839    my $md5 = new Digest::MD5;
840    foreach (sort { $a->[0] cmp $b->[0] } @files) {
841        my $f = $_->[1];
842        open my $A, $f;
843        $md5->addfile($A);
844        #my $tmpmd5 = new Digest::MD5;
845        #local *A, open A, $f;
846        #$tmpmd5->addfile(*A);
847        #print "MD5: $_->[0] (", $tmpmd5->hexdigest() ,")\n";
848    }
849    my $digest = $md5->hexdigest;
850    # print "IGNORE " , join " ",keys %$ignore ,"\n";
851    return $digest
852}
853
854sub md5_add_tree {
855    my ($to_check, $files, $ignore) = @_;
856    foreach (@$to_check) {
857        my ($dest, $f) = @$_;
858        $f =~ m|/?\.{1,2}$| and next;
859        $f =~ /~$/ and next;
860        $f =~ s|//+|/|g;
861        $dest =~ s|//+|/|g;
862        $ignore->{$dest} and next;
863        if (-d $f) {
864            md5_add_tree([ map { [ "$dest/$_", "$f/$_" ] } all $f ], $files, $ignore)
865        } else {
866            push @$files, [ $dest, $f ]
867        }
868    }
869}
870
871sub log_ {
872    my ($msg, $verbose, $log, $level) = @_;
873    return if $level > $verbose;
874    my $LOG;
875    if (!$log) { open $LOG, ">&STDERR" } else { $LOG = $log }
876    print $LOG $msg;
877}
878
879# TODO must add some check of maximum authorized size
880sub include_md5 {
881    my ($iso, $write, $verbose) = @_;
882    my $ISO; 
883    if ($write) {
884        open $ISO, "+<$iso" or return "ERROR include_md5: unable to open $iso ($!)\n"; 
885    } else {
886        open $ISO, $iso or return "ERROR include_md5: unable to open $iso ($!)\n";     
887    }
888    binmode $ISO;
889    my $offset = 16*2048;
890    # blank header
891    seek $ISO, $offset, 0;
892    my ($buf, $msg);
893    while (1) {
894        read $ISO,$buf,2048;
895        my $c = ord $buf;
896        last if $c == 1;
897        return "ERROR include_md5: could not find primary volume descriptor\n" if $c == 255;
898        $offset += 2048
899    }
900    my $size = ((ord substr $buf, $SIZE_OFFSET, 1) * 0x1000000 + 
901                (ord substr $buf, $SIZE_OFFSET + 1, 1) * 0x10000 + 
902                (ord substr $buf, $SIZE_OFFSET + 2, 1) * 0x100 + 
903                (ord substr $buf, $SIZE_OFFSET + 3, 1)) * 2048;
904    my $volume = substr $buf, 30, 40;
905    $volume =~ s/^\s*(\S.*\S)\s*$/$1/;
906    my $id = substr $buf, 180, 20;
907    $msg = "include_md5: volume name $volume volume id: $id iso size $size\n";
908    seek $ISO, $offset + $INFO_OFFSET, 0;
909    read $ISO, $buf,512;
910    my ($md5sum) = $buf =~ /.md5 = (\S+)/;
911    $msg .= "include_md5: previous data $buf\n";
912    seek $ISO, 0, 0;
913    my $md5 = new Digest::MD5;
914    my $read = read $ISO, $buf, $offset + $INFO_OFFSET;
915    $md5->add($buf);
916    seek $ISO, 512, 1;
917    $read += 512;
918    $|=1;
919    my $val = int $size/2048/100;
920    $verbose and print "\rReading: 0 %";
921    my ($i, $j);
922    # skip last $SKIP bytes that sometimes are not correctly burned by some drives
923    my $n = 1;
924    while ($n && $read < $size - $SKIP * 2048) {
925        $n = read $ISO, $buf,2048;
926        print "\rReading: ", $j++, " %" if ($verbose && !($i++ % $val));
927        $md5->add($buf);
928        $read += $n;
929    }
930    print "\n";
931    my $digest = $md5->hexdigest;
932    $msg .= "include_md5: computed md5 $digest\n";
933    my $res = $md5sum eq $digest;
934    if ($md5sum) {
935        $msg .= "include_md5: previous md5 $md5sum\ninclude_md5: md5sum check ";
936        $msg .= $res ? "OK\n" : "FAILED\n"
937    }
938    print $msg if $verbose;
939    $write or return $res;
940    seek $ISO, $offset + $INFO_OFFSET, 0;
941    my $str = substr "$volume.md5 = $digest", 0, 512;
942    my $l = length $str;
943    print $ISO ($l > 512 ? substr $str, -1, 512 : $str . ' ' x (512 - $l));
944    close $ISO
945}
946
947sub convert_size {
948    my ($size, $default, $LOG) = @_;
949    if ($size =~ /[\d.]+g$/i) {
950        $size = $size * $GB;
951    } elsif ($size =~ /[\d+.]+m$/i) {
952        $size = $size * $MB;
953    } elsif ($size =~ /[\d+.]+k$/i) {
954        $size = $size * $KB;
955    } elsif ($size !~ /[\d+.]+$/i) {
956        log_("ERROR disc: $size is invalid, using default ($default)\n",1,$LOG);
957        $size = $default;
958    }                   
959   $size 
960}
961
9621
963
964#
965# Changelog
966#
967# 2002 02 27
968# make the locale constraint free on the right for cleanrpmsrate locale addition (kde-i18n-zh_BG and such)
969#
970# 2002 03 03
971# fix typo in checkdiscs
972#
973# 2002 03 04
974# fix checkcds pb with check[0] used.
975#
976# 2002 03 07
977# add possibility to remove package from rpmsrate
978#
979# 2002 03 12
980# add all .*kernel- in rpmsrate
981#
982# 2002 03 17
983# add serial name instead of cdnumber when name is not know
984#
985# 2002 05 07
986# add check_discs, compute_md5, write_graft, md5_add_tree
987#
988# 2002 05 22
989# fix a pb in md5
990#
991# 2002 05 25
992# add log function
993#
994# 2002 06 05
995# fix md5 for isolinux
996#
997# 2002 08 12
998# fix/change cleanrpmsrate
999#
1000# 2002 09 04
1001# do not open for writing iso file in include_md5 if not in write mode
1002#
1003# 2002 09 25
1004# add completion feedback to include_md5
Note: See TracBrowser for help on using the repository browser.