TrustMiner2/altname-legacy.pl

#!/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";
}