diff -r 000000000000 -r 0d30ea853889 bin/mkpool
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/bin/mkpool	Thu Mar 05 09:19:21 2009 +0100
@@ -0,0 +1,324 @@
+#! /usr/bin/perl
+
+# © 2006 2007 2008 Heiko Schlittermann <hs@schlittermann.de>
+
+
+use strict;
+use warnings;
+
+use File::Find;
+use FindBin;
+use IO::File;
+use Digest::MD5;
+use Cwd;
+use AppConfig;
+use File::Temp;
+
+use lib "$FindBin::RealBin/../lib";
+use Debian::ChangesFile;
+use Debian::ControlFile;
+use Debian::DebFile;
+use Debian::Repository;
+use Debian::Dpkg;
+
+chdir $ENV{HOME};
+
+# LISTDIR - hier liegen nur die Filelisten, die apt-ftparchive verarbeiten
+# muß, sie werden später nicht gebraucht
+my $LISTDIR	= "/home/debian/var/dists";		 
+my $TIMESTAMP	= "var/.pool";
+
+# APTROOT - das, was dann als APT-Repository freigegeben wird, also
+# sollte es dists/ und pool/ enthalten
+my $APTROOT	= "/home/ftp/pub/apt2/debian-ius";
+
+my $ORIGIN	= "schlittermann";			# für das Release-File
+my @DISTS	= qw/stable testing unstable/;			
+my @SECTIONS	= qw/main contrib non-free test/;
+my @BINARCHS	= qw/i386 ia64 amd64/;
+my @SRCARCHS	= qw/source/;
+
+my @ARCHS = (@SRCARCHS, @BINARCHS);
+
+my $Cf = new AppConfig (
+    { CASE => 1 },
+    "signed" =>             { ARGS => "!", DEFAULT => 1 },
+    "remove-obsolete" =>    { ARGS => "!" },
+    "verbose" =>	    { ARGS => ":i" },
+    "stop" =>		    { ARGS => "=s", DEFAULT => "" },
+    "force" =>		    { ARGS => "!" },
+);
+
+sub processChanges();
+sub getChanges();
+
+MAIN: {
+
+    $Cf->getopt or die;
+    $Cf->verbose(1) if defined $Cf->verbose && $Cf->verbose == 0;
+    $Cf->verbose(0) if not defined $Cf->verbose;
+
+    $| = 1;
+
+    # absolutize the paths
+    $LISTDIR = cwd() . "/$LISTDIR" if $LISTDIR !~ /^\//;
+    $APTROOT = cwd() . "/$APTROOT" if $APTROOT !~ /^\//;
+    $TIMESTAMP = cwd() . "/$TIMESTAMP" if $TIMESTAMP !~ /^\//;
+
+    if (!$Cf->force) {
+	exit 0 if ((stat $TIMESTAMP)[9]||0) > ((stat "var/.import")[9]||0);
+    }
+
+    # create the dists/ hierarchy
+    my $repos = new Debian::Repository {
+	root => $APTROOT,
+	origin => $ORIGIN,
+	dists => \@DISTS,
+	sections => \@SECTIONS,
+	binary => \@BINARCHS,,
+	source => \@SRCARCHS,
+    };
+
+    $repos->checkDirs(create => 1, umask => 022);
+
+    chdir($_ = $repos->root) or die "Can't chdir to $_: $!\n";
+
+    # Nun suchen wir die .changes-Files .... und verarbeiten 
+    # diese.  Das muß erstmal getan werden, weil wir nur so wissen,
+    # welches je Distribution/Architecture das jeweils neueste Paket
+    # ist
+    find({ wanted => sub { /\.changes$/ and processChanges(); }}, "pool/");
+    print "\n" if -t STDIN;
+
+    if ($Cf->stop eq "changes") {
+	if ($Cf->verbose) {
+	    while (my ($k, $chg) = getChanges()) { print "$k: ".$chg->key("version")."\n" }
+	}
+	exit 0;
+    }
+
+    # Nun gehen wir durch diese Liste der gefundenen Changes-Files
+    # und erzeugen für jedes Paket einen Eintrag in der entsprechenden Liste
+    # für das dann später loslaufende apt-ftparchive
+    my (%LISTS, %KEEP);
+    while (my ($k, $changes) = getChanges()) {
+    #print "$k ($changes)\n";
+    #next;
+
+	my $distribution = $changes->key("distribution");
+	print join(" " ,"$k:", $changes->keys(qw/source version/), $distribution, "\n")
+	    if -t STDIN;
+
+	$KEEP{$changes->path} = 1;
+
+	# Binary files (brauchen eine etwas andere Behandlung als die etwas weiter
+	# unten kommenden source Files
+	foreach my $file ($changes->binaryFiles) {
+
+	    # architectures is property of the each binary .deb file itself
+	    my $deb = new Debian::DebFile $file;
+	    my @archs = map { /^all$/ ? @BINARCHS : $_ } $deb->key("architecture");
+	    my $component = $file->component;
+
+	    foreach my $arch (@archs) {
+
+		my $tag = "$distribution.$component.$arch.list";
+		my $path = $file->path;
+
+		print "\t" . $file->file . " -> $tag\n" if -t STDIN;
+
+		$LISTS{$tag} = new IO::File $_ = ">$LISTDIR/$tag" or die "Can't open $_: $!\n"
+		    unless exists $LISTS{$tag};
+
+		$LISTS{$tag}->print("$path\n");
+
+		$KEEP{$path} = 1;
+	    }
+	}
+
+	foreach my $file ($changes->sourceFiles) {
+	    my $dsc = new Debian::ControlFile $file;
+
+	    my $path = $file->path;
+	    my $component = $file->component;
+	    my $tag = "$distribution.$component.source.list";
+
+	    print "\t" . $file->file . " -> $tag\n" if -t STDIN;
+	    
+	    $LISTS{$tag} = new IO::File $_ = ">$LISTDIR/$tag" or die "Can't open $_: $!\n"
+		unless exists $LISTS{$tag};
+
+	    $LISTS{$tag}->print("$path\n");
+
+	    $KEEP{$path} = ();
+	    @KEEP{map { $_->path } $dsc->files} = ();
+	}
+    }
+
+    # Nun wären wir mit den Listen eigentlich fertig, aber apt-ftparchive ist traurig, wenn
+    # es eine Liste erwartet und es ist keine da. Also müssen wir auch für die Dinge, für die bisher
+    # keine Liste angelegt wurde, diese Liste anlegen.
+    # Da aktuell offenen Listen sowieso nicht mehr benötigt werden, schließen wir sie bei dieser
+    # Gelegenheit gleich.
+
+    foreach my $dist (@DISTS) { foreach my $sect (@SECTIONS) { foreach my $arch (@ARCHS) {
+	    my $tag = "$dist.$sect.$arch.list";
+
+	    my $fh;
+	    if (exists $LISTS{$tag}) {
+		$fh = $LISTS{$tag};
+		delete $LISTS{$tag};
+	    } else {
+		$fh = new IO::File ">$LISTDIR/$tag";
+	    }
+	    $fh->close;
+    } } }
+
+    exit 0 if $Cf->stop eq "lists";
+
+    ## jetzt sind die File-Listen fertig erstellt und es wird Zeit, apt-ftparchive
+    # aufzurufen
+
+    if (!-t STDIN) {
+	open(SAVEOUT, ">&STDERR");
+	open(STDERR, ">/dev/null");
+    }
+
+    system("apt-ftparchive", generate => "$ENV{HOME}/etc/apt-ftparchive");
+
+    open(STDERR, ">&SAVEOUT") if !-t STDOUT;
+    close(SAVEOUT);
+
+    if ($?) {
+	die "Problem running apt-ftparchive, exit was $?\n"
+    }
+
+    if ($Cf->signed) {
+	my $pid = fork();
+
+	if ($pid) {
+	    waitpid($pid, 0);
+	} 
+	else {
+	# Und nun die Release-Files
+	# Wir haben zwar schon welche dort liegen (die entstehen beim Pool-Repository
+	# einrichten, aber wenn wir mit Keys haben wollen, dann sind die dort nicht 
+	# ausreichend.
+	my $release_file = "Release";
+	my $release_sig = "$release_file.gpg";
+	foreach my $dist (@DISTS) {
+		my $dir = "$APTROOT/dists/$dist";
+
+		chdir $dir or die "Can't chdir to $dir: $!\n";
+
+		if (-f $release_file) {
+		    open(my $r, $release_file) or die "Can't open $release_file: $!\n";
+		    $_ = join "", grep { /^\S+:\s*\S.*$/ && !/^Date:/i } <$r>;
+		    close($r);
+
+		    if (!/^Suite:/ms && /^Release:\s*(\S+)$/ms) {
+			$_ .= "Suite: $1\n";
+		    }
+		}
+
+		# apt-ftparchive -> tmpfile
+		open(my $in, "apt-ftparchive release .|") or die "Problem running apt-ftparchive: $!\n";
+		my $out = new File::Temp(DIR => ".") or die "Can't create tmp file: $!\n";
+		print {$out} $_, grep !/ Release(?:\.gpg)?$/, <$in>; # das Release-File selbst ist da auch noch drin - weg damit
+		close($in) or die "Problem after running apt-ftparchive: $! ($?)";
+		close($out);
+
+		# Signatur -> tmpfile
+		my $sig = new File::Temp(DIR => ".");
+		open($in, "gpg --sign --armor --detach-sign --output - " . $out->filename . "|") or die "Problem running gpg: $!\n";
+		print {$sig} <$in>;
+		close($in) or die "Problem after running gpg: $! ($?)\n";
+		close($sig);
+
+		# tmpfiles -> Wirklichkeit
+		chmod(0644, $out->filename, $sig->filename);
+		rename($out->filename, $release_file) or die "Can't rename @{[$out->filename()]} to $release_file: $!\n";
+		rename($sig->filename, $release_sig) or die "Can't rename @{[$sig->filename()]} to $release_sig: $!\n";
+	    }
+	}
+    }
+
+    # Ok, und nun gehen wir noch mal durch den Baum und gucken nach Files, die nicht
+    # mehr gebraucht werden
+    find({wanted => sub {
+	return if not -f;
+	if (not exists $KEEP{$File::Find::name}) {
+	    # leave some notice to the importer
+
+	    if ($Cf->get("remove-obsolete")) {
+		unlink $_ or die "Can't unlink $File::Find::name: $!\n";
+		return;
+	    }
+	    print "-$File::Find::name\n" if -t STDIN;
+	    return;
+	}
+	print " $File::Find::name\n" if -t STDIN;
+    }}, "pool/");
+
+    # print "TO BE REMOVED:\n", join  "\n", map { $_->{file} } @OBSOLETE;
+
+    open(X, ">$TIMESTAMP") or die "$TIMESTAMP: $!";
+    print X $$;
+    close(X);
+}
+
+# Watchout: Wir sitzen im Verzeichnis mit dem betroffenen File!
+# Darum übergeben wir noch den Prefix, damit wir das Verzeichnis später 
+# wiederfinden.
+{
+    my %CHANGES;
+
+sub processChanges() {
+    my $changes = new Debian::ChangesFile($_, path => $File::Find::name);
+
+    # Nun rausfinden, ob wir noch ältere Files haben, die können wir dann
+    # getrost ignorieren
+
+    # Zuerst laufen wir durch gucken suchen uns die aktuellsten .changes-Files
+    # raus (key ist source+distribution+architecture)
+    # Ein Problem haben wir: Wenn die Archtektur sich ändert:
+    #	1.2 i386
+    #   2.0 all
+    # -> also müssen wir für jede(!) Architektur ein Tag haben und ein aktuellstes
+    # File.  (Aber aus 'all' machen wir die Liste der uns bekannten Architekturen
+
+    print join(" ", $changes->keys(qw/source distribution version architecture/)), "\n" if $Cf->verbose > 1;
+
+    foreach my $tag (map { join "^", $changes->keys(qw/source distribution/), $_ } $changes->archs) {
+
+	if (not exists($CHANGES{$tag})) {
+	    $CHANGES{$tag} = $changes;
+	    print "." if -t STDIN;
+	    next;
+	}
+
+	my $a = $CHANGES{$tag}->key("version");
+	my $b = $changes->key("version");
+
+	#printf "$tag: $a gt $b %d\n", Debian::Dpkg::compareVersions($a, "ge", $b);
+
+	if (Debian::Dpkg::compareVersions($a, "ge", $b)) {
+	    print "-" if -t STDIN;
+	    next;
+	}
+
+	$CHANGES{$tag} = $changes;
+	print "+" if -t STDIN;
+	print "replacing $tag $a => $b\n" if $Cf->verbose;
+	
+    }
+
+    return;
+} 
+
+sub getChanges() { return each(%CHANGES); }
+
+
+}
+
+# vim:sts=4 sw=4 aw ai sm: