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 + + +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: