source: soft/build_system/build_system/mkcd/tags/v2-6-5/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: 7.3 KB
Line 
1package Mkcd::Tools;
2
3sub printTable;
4sub getTracks;
5sub du;
6sub cpal;
7sub checkcds;
8sub cleanrpmsrate;
9
10our $VERSION = '0.0.4';
11
12use strict;
13use File::NCopy qw(copy);       
14require Exporter;
15our @ISA = qw(Exporter);
16our @EXPORT = qw(printTable getTracks du cpal checkcds cleanrpmsrate);
17
18=head1 NAME
19
20tools - mkcd tools
21
22=head1 SYNOPSYS
23
24    require mkcd::tools;
25
26=head1 DESCRIPTION
27
28C<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=cut
53
54sub printTable {
55    my ($a,$log) = @_;
56    my $LOG; if ($log) { my $LOG = $log } else { open $LOG, ">&STDERR"}
57    #
58    # iterative version of a recursive scanning of a table.
59    # ex: @config = [[[1,3],3,[1,3,[1,3]]],3,4,[4,[4,4]]]
60    #   
61    my @A;
62    my @i;
63    my @tab;
64    my $i = 0;
65    while ($a){
66        my $u = ref $a;
67        if ($u eq 'ARRAY') {
68            while ($i < @$a){
69                my $b = $a->[$i];
70                my $t = ref $b;
71                if ($t eq 'ARRAY'){
72                    push @tab, "\t";
73                    push @i, $i+1;
74                    push @A, $a;
75                    $i = 0;
76                    $a = $b;
77                    next
78                } elsif ($t eq 'HASH') { 
79                    $i++; print {$LOG} "@tab", join ' ',keys %$b,"\n"
80                } else { $i++; print {$LOG} "@tab$b\n" }
81            }
82        } else { print {$LOG} "$a\n" }
83        pop @tab;
84        $i = pop @i;
85        $a = pop @A;
86    }
87
88}
89
90sub getTracks{
91    my ($tracks,$log) = @_;
92    my $LOG; if ($log) { my $LOG = $log } else { open $LOG, ">&STDERR"}
93    print {$LOG} "getTracks: $tracks\n";
94    my @tracks = split ',',$tracks;
95    my @t;
96    foreach (@tracks){
97        /(\d+)/ and push @t, $1;
98        /(\d+)-(\d+)/ and push @t, $1..$2       
99    }
100    my @tracks;
101    my %done;
102    for(my $i = $#t; $i >= 0; $i-- ){
103        push @tracks, $t[$i] if !$done{$t[$i]};
104        $done{$t[$i]}=1
105    }
106    \@tracks;
107}
108
109sub du {
110    my ($path,$size) = @_;
111    my $size;
112    if (-d $path){
113        opendir O, $path;
114        foreach (readdir O){
115            /^\.{1,2}$/ and next;
116            -l "$path/$_" or $size += du("$path/$_")
117        }
118    } else {
119        -l $path or $size = (stat $path)[7] + 2048;
120    }
121    $size
122}
123
124sub cpal{
125    my ($source,$dest,$exclude,$verbose,$log) = @_;
126    my $LOG; if ($log) { my $LOG = $log } else { open $LOG, ">&STDERR"}
127    if ($exclude && "$source/$_" =~ /$exclude/) {return 0}
128    if (!-l $source && -d $source){
129        mkdir "$dest";
130        opendir O, $source; 
131        foreach (readdir O){
132            /^\.{1,2}$/ and next;
133            cpal("$source/$_","$dest/$_",$exclude,$verbose)
134        }
135    }else {
136        my $err;
137        if (-d $dest){ my ($filename) = $source =~ /([^\/]*)$/; $dest .= "/$filename"}
138        $err = link "$source","$dest" ;
139        $verbose and print {$LOG} "cpal: link $source -> $dest\n" ; 
140        if (!$err) { 
141            print {$LOG} "Linking failed $source -> $dest: $!, trying to copy\n" ; 
142            $err = copy "$source", "$dest"; 
143            if (!$err) { print {$LOG} "Copying failed $source -> $dest: $!,\n"; return 0}
144        }
145    }
146    1
147}
148
149#
150# check depslist, depslists.ordered and hdlists
151#
152sub checkcds{
153    my ($tops,$first,$log) = @_;
154    my $LOG; if ($log) { my $LOG = $log } else { open $LOG, ">&STDERR"}
155    my $i;
156    my $top;
157
158    if ($first) { $top = $tops->[$first]} else { while (!$tops->[$i]){$i++}; $top = $tops->[$i]} ;
159
160    local *A; open A, "$top/Mandrake/base/depslist.ordered" or print {$LOG} "ERROR: unable to open $top/Mandrake/base/depslist.ordered" and return 0;
161    my %depspackages;
162    my %dup;
163    my $ok = 1;
164    my $OK=1;
165    print {$LOG} "Duplicate version: ";
166    while (<A>){
167        my ($pkg,$name) = ((split)[0]) =~ /((.*)-[^-]+-[^-]+\.[^:]+)/;
168        $dup{$pkg} and do { print {$LOG} "\n$pkg"; $ok=0 ; $OK=0};
169        $dup{$name} and do { print {$LOG} "\n$name"; $ok=0 ; $OK=0};
170        $depspackages{$pkg} = 1;
171        $dup{$pkg} = 1;
172        $dup{$name} = 1;
173    }
174    $ok ? print {$LOG} " OK\n" : print {$LOG} " FAILED\n";
175
176    my %hdlist;
177    my %rep;
178    my $num;
179    local *A; open A, "$top/Mandrake/base/hdlists" or die "unable to open $top/Mandrake/base/hdlists";
180    while (<A>){
181        my ($hdlist, $dir, undef) = split;
182        $num++;
183        local $_;
184        local *B; open B, "packdrake -l $top/Mandrake/base/$hdlist|" or die "unable to open packdrake $top/Mandrake/base/$hdlist|";
185        <B>;
186        print {$LOG} "\nIn $hdlist, not in depslist:";
187        my $ok = 1;
188        my $p;
189        my $k;
190        my %key;
191        while (<B>){
192            $p = (split)[2];
193            if ($p =~ /(.*):(.*)/){
194                $p = $1;
195                $k = $2;
196                $key{$2} = $1
197            }else { $key{$p} = $p } 
198            # $p =~ s/(\.(i386|i486|i586|i686|noarch))?$//;
199            $hdlist{$p} = 1;
200            if (!$depspackages{$p}) {print {$LOG} "\n$p"; $ok=0; $OK=0}
201        }
202        $p or do { print {$LOG} "$hdlist is empty\n" ; $OK=0};
203        $ok and print {$LOG} " OK\n";
204        local *C;
205        opendir C, "$tops->[$num]/$dir" or opendir C, "$top/$dir";
206        my $ok = 1;
207        print {$LOG} "\n\nIn $tops->[$num]/$dir, not in depslist:";
208        readdir C;
209        readdir C;
210        foreach (readdir C){
211            s/\.rpm// or next;
212            $rep{$key{$_}} = 1;
213            if (!$depspackages{$key{$_}}) {print {$LOG} "\n$_"; $ok=0; $OK = 0}
214        }       
215        $ok ? print {$LOG} " OK\n" : print {$LOG} " FAILED\n";
216    }
217
218    print {$LOG} "\n\nIn depslist, not in hdlist*.cz:";
219    my $ok = 1;
220    foreach (keys %depspackages){ 
221        if (!($hdlist{$_})) {print {$LOG} "\n$_"; $ok=0; $OK=0}
222    }
223    $ok ? print {$LOG} " OK\n" : print {$LOG} " FAILED\n";
224
225    print {$LOG} "\n\nIn depslist, not in RPMS*:";
226    my $ok = 1;
227    foreach (keys %depspackages){ 
228        if (!$rep{$_}) {print {$LOG} "\n$_"; $ok=0; $OK=0}
229    }
230    $ok ? print {$LOG} " OK\n" : print {$LOG} " FAILED\n";
231    print {$LOG} "\n";
232    $OK
233}
234
235sub cleanrpmsrate {
236    my ($rpmsrate,$R,@rpms,$log) = @_;
237    my $LOG; if ($log) { my $LOG = $log } else { open $LOG, ">&STDERR"}
238    my %rpms;
239    foreach (@rpms){
240        -d or print {$LOG} "ERROR: $_ is not a directory\n" and next;
241        local *A; opendir A, $_;
242        foreach (readdir A) { if (/-devel-/) { s/(.*?)(_*[\d.]*)-devel-[^-]+-[^-]+\.[^.]+\.rpm$//; $2 and $rpms{$1} = $2}}
243    }
244    open A, $rpmsrate;
245
246    my %done;
247    my $current;
248    my $rate;
249    while (<A>){
250        s/#.*//;
251        /^\s*$/ and print $R $_ and next;
252        if (/^(\S+)/) {
253            print $R $_;
254            $current = $1;
255            next
256        }
257        my ($indent,$r,$prefix,$data) = /^(\s*)([1-5]?)(\s*(?:(?:!\s*)?[0-9A-Z_]*\s+)*(?:(?:!\s*)[0-9A-Z_]+"[^"]*"(?:\s+(?:\|\|\s+)?)*)*\s*)(.*)$/;
258        print "indent $indent r $r prefix $prefix data $data\n";
259        $r and $rate = $r;
260        my @k;
261        $data or print $R "$indent$r$prefix" and next;
262        my ($postfix) = $data =~ /(\s*)$/;
263        foreach (split ' ', $data) {
264            #FIXME need to handle doble the same way the install is doing, not just removing them.
265            my $c = $_;
266            if (!($current eq "INSTALL")) {
267                $done{$_} and next;
268                my $a; my ($b) = $_ =~ s/(-devel)// ? "-devel" : "";
269                if ($b && ($rpms{$_} || ($rpms{"lib$_"} and $a = "lib"))) { 
270                    my $d = "$a$_" . $rpms{"$a$_"} . "$b"; 
271                    if (!$done{$d}){ $done{$d} = $rate; push @k, $d, $c}
272                }else { push @k, $c }
273            } else { push @k, $c}
274            $done{$c} = $rate;
275        } 
276        @k and print $R "$indent$r$prefix@k$postfix\n"
277    }
278    1
279}
280
2811
Note: See TracBrowser for help on using the repository browser.