#!/usr/bin/perl
# (c) 2011 by Immo 'FaUl' Wehrenberg

# be most verbose
use strict; use warnings; use diagnostics;

use IO::Uncompress::Bunzip2;
use IO::Uncompress::Gunzip;
# use IO::Uncompress::UnLzma; #does not exist on debian

use Storable;

use Env qw($HOME);
use vars qw($cache $dists $arch @sources @distributions);
# directory with mirror from 
$arch = "i386";
$dists = "dists/";
#distris in cronological order
@distributions = ("potato", "woody", "sarge", "etch", "lenny", "squeeze"); 

$cache = "$HOME/.apt-sec/cache/";
eval {
	mkdir "$HOME/.apt-sec";
	mkdir $cache;
};

sub recursor($$$);
sub getarrayofpackeges($);

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 = $cache."/".$f."_".$a[9].".".$suffix;
	return $x;
}

sub getcached ($;$) {
	my %file;
	my $cachename = cachename shift(), shift();
	eval {
		my $file = retrieve $cachename;
		%file = %{$file};
	};
	return %file;
}

# 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;
}


# intersection (\@array1, \@array2)
# returns intersection of both arrays
sub intersection($$) {
	my @arr1 = uniq(pop);
	my @arr2 = uniq(pop);

	my @intersection;
	my %c;
	foreach (@arr1, @arr2){
		$c{$_}++;
	}
	foreach (keys %c) {
		if ($c{$_} > 1) {
			push @intersection, $_;
		}
	}
	return @intersection;
}

# uniq(\@array)
# returns an array which all unique elements of @array
sub uniq($) {
	my %c = map {$_, 1} @{pop()};
	return keys %c;
}

# 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 recursor($$$) {
	my $start = pop;
	my @names = @{pop()};
	my @distris = @{pop()};
	my $dist = pop(@distris);
	my %pkg;
	my @list = @names;
	my %binfile = parsefile "$dists/$dist/binary-$arch/Packages.bz2";
	my %sourcefile = parsesource "$dists/$dist/source/Sources.bz2";
	foreach my $p (@names) {
		eval {
			push @sources, pkg2src(\%sourcefile, $p);
			@sources = uniq(\@sources);
			%pkg = %{$binfile{$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 (@distris){
		return recursor(\@distris, \@names, 0);
	} else {
		return (@names);
	}
}

sub main() {
	$\ = "\n";
	$, = "\n";
	my @dists = @distributions;
	my $F;

	my @binpackages = recursor(\@dists, \@ARGV, 1);
	#print @l;
	#print "---";
	print @sources;
}

main();