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