123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235 |
- #!/usr/bin/perl
- ###############################################################################
- ##
- ## Some legacy, not-quite-working code to automatically find alternative
- ## package names based on dependency tracking
- ## (Distributions use dependencies to assure smooth upgrades..)
- ##
- ###############################################################################
- use strict;
- use warnings;
- my @debian_dists = ("potato", "woody", "sarge", "etch", "lenny", "squeeze");
- my @ubuntu_dists = ("dapper", "hardy", "jaunty", "karmic", "lucid", "maverick", "natty");
- # uniq(\@array)
- # returns an array which all unique elements of @array
- sub uniq($) {
- my %c = map {$_, 1} @{pop()};
- return keys %c;
- }
- sub getfilehandle($) {
- my $name = pop;
- my $fd;
- if ($name =~ /.bz2$/) {
- $fd = new IO::Uncompress::Bunzip2 $name or die "$name: $!";
- }
- elsif ($name =~ /.gz$/) {
- $fd = new IO::Uncompress::Gunzip $name or die "$name: $!";
- }
- # elsif ($name =~ /.lzma$/) {
- # $fd new IO::Uncompress::UnLzma $name or die "$name: $!";
- else {
- open $fd, $name or die "$name: $!";
- }
- return $fd;
- }
- sub cachename($;$) {
- my $f = shift;
- my $suffix = shift;
- $suffix = "cache" if ! defined $suffix;
- my @a = stat $f;
- $f =~ s/\/\//\//g;
- $f =~ s/\//_/g;
- my $x = $config->{"cache_dir"} . "/" . $f . "_" . $a[9] . "." . $suffix;
- return $x;
- }
- sub getcached ($;$) {
- my %file;
- my $cachename = cachename shift(), shift();
- eval {
- my $file = retrieve $cachename;
- %file = %{$file};
- };
- return %file;
- }
- # intersection (\@array1, \@array2)
- # returns intersection of both arrays
- sub intersection($$) {
- my @arr1 = uniq(pop);
- my @arr2 = uniq(pop);
- my @common;
- my %c;
- foreach (@arr1, @arr2){
- $c{$_}++;
- }
- foreach (keys %c) {
- if ($c{$_} > 1) {
- push @common, $_;
- }
- }
- return @common;
- }
- # parsefile($filehandle)
- # returns hash of the package file given with $filename, key is package name,
- # value is a reference to a hash with key: value
- sub parsefile($) {
- my $filename = pop;
- # do we have stuff cached?
- my %file = getcached($filename, "parsefile.cache");
- return %file if %file;
- my $fd = getfilehandle $filename;
- # this is the parser
- my $savedsl = $/;
- $/ = "\n\n";
- while (<$fd>) {
- my %dict;
- $_ = "\n".$_;
- ($_, %dict) = split /\n(\w+): /; # first is crap
- $file{$dict{"Package"}} = \%dict;
- }
- $/ = $savedsl;
- close $fd;
- # cache result
- store \%file, cachename ($filename, "parsefile.cache");
- return %file;
- }
- # getarrayofpackeges($field)
- # Returns an array of all packages given in @fields (as returned by getfield()
- # strips versions
- sub getarrayofpackages($) {
- $_ = pop or return;
- s/(\(.*?\)|\s)//g; # remove everything inside parathesis and whitespaces
- return split /,/ or ();
- }
- # parsesource($filehandle)
- # parses the sourcefile represented by the open file in $filehandle
- # returns a dict with each binary package name reference to a
- # source package hash
- sub parsesource($) {
- my $filename = pop;
- # do we have stuff cached?
- my %file = getcached($filename, "parsesource.cache");
- return %file if %file;
- # if not, parse
- my $savedsl = $/;
- $/ = "\n\n";
- my $fd = getfilehandle $filename;
- while (<$fd>) {
- my %dict;
- $_ = "\n".$_;
- ($_, %dict) = split /\n(\w+): /; # first is crap
- foreach my $bin (getarrayofpackages ($dict{"Binary"})) {
- $file{$bin} = \%dict;
- }
- }
- $/ = $savedsl;
- close $fd;
- # cache
- store \%file, cachename ($filename, "parsesource.cache");
- return %file;
- }
- # old_names_in_file($name, $filehandle)
- # returns array of alternative names to $name in the opened Package
- # file ($filehandle)
- sub old_names_in_file($) {
- my %pkg = %{pop()};
- my @replaces = getarrayofpackages($pkg{"Replaces"});
- my @conflicts = getarrayofpackages($pkg{"Conflicts"});
- return intersection(\@replaces, \@conflicts);
- }
- # pkg2src(%sources, $packagename)
- # return the source package to a given binary package
- sub pkg2src($$){
- my $p = pop;
- my %f = %{pop()};
- if (!$p || !$f{$p}) {
- return ();
- }
- return $f{$p}->{"Package"};
- }
- # recursor (\@distris, \@names, $start)
- # recursively works through all @dists (filenames of uncompressed Package files
- # from debian) from last to first. Tries to find alternative names to the names
- # given in @names), if $start = 1, dies if name is not found in the current dist
- sub get_aliases($$$$);
- sub get_aliases($$$$) {
- my @dists = @{shift()};
- my @names = @{shift()};
- my @sources = @{shift()};
- my $start = shift;
- my %pkg;
- my @list = @names;
-
- my $dist = pop(@dists);
- my $dists_dir = $config->{"dists_dir"};
- my $arch = $config->{"arch"};
- my %pkglist = parsefile "$dists_dir/$dist/main/binary-$arch/Packages.bz2";
- my %srclist = parsesource "$dists_dir/$dist/main/source/Sources.bz2";
- foreach my $p (@names) {
- eval {
- push @sources, pkg2src(\%srclist, $p);
- @sources = uniq(\@sources);
- %pkg = %{$pkglist{$p}};
- @list = old_names_in_file(\%pkg);
- @names = (@names, @list);
- @names = uniq(\@names);
- } or do {
- die "Could not find any package named '$p'" if grep ($p, @ARGV) && $start;
- };
- }
- @names = uniq(\@names);
- if (@dists){
- return get_aliases(\@dists, \@names, \@sources, 0);
- } else {
- return @sources;
- }
- }
- # Tries to find alternative package names by tracking bin pkg dependencies
- # through distributions. Does not work. We use unifySrcName() instead.
- sub altname {
- my $spkg = shift;
- my @pkg = ();
- my @src = ();
- my @dists;
-
-
- given ($state->{"vendor"}) {
- when ($_ eq "debian") { @dists = @debian_dists; }
- when ($_ eq "ubuntu") { @dists = @ubuntu_dists; }
- #when ($_ eq "redhat") { ($id,$adv) = checkRHSA; }
- default { die "Unsupported distribution $_"; }
- };
-
- # get all bin pkg for this src pkg
- #foreach my $pkg (keys %$pkg2src) {
- # push @pkg, $pkg if ($spkg eq $pkg2src->{$pkg} )
- #}
-
- @pkg = ($spkg);
- @src = get_aliases(\@dists, \@pkg, \@src, 1);
- print "Aliases for bin-pkg $spkg: @src\n";
- }
|