1 #! /usr/bin/perl

     2 

     3 # © 2006 2007 2008 Heiko Schlittermann <hs@schlittermann.de>

     4 

     5 

     6 use strict;

     7 use warnings;

     8 

     9 use File::Find;

    10 use FindBin;

    11 use IO::File;

    12 use Digest::MD5;

    13 use Cwd;

    14 use AppConfig;

    15 use File::Temp;

    16 

    17 use lib "$FindBin::RealBin/../lib";

    18 use Debian::ChangesFile;

    19 use Debian::ControlFile;

    20 use Debian::DebFile;

    21 use Debian::Repository;

    22 use Debian::Dpkg;

    23 

    24 chdir $ENV{HOME};

    25 

    26 # LISTDIR - hier liegen nur die Filelisten, die apt-ftparchive verarbeiten

    27 # muß, sie werden später nicht gebraucht

    28 my $LISTDIR	= "/home/debian/var/dists";		 

    29 my $TIMESTAMP	= "var/.pool";

    30 

    31 # APTROOT - das, was dann als APT-Repository freigegeben wird, also

    32 # sollte es dists/ und pool/ enthalten

    33 my $APTROOT	= "/home/ftp/pub/apt2/debian-ius";

    34 

    35 my $ORIGIN	= "schlittermann";			# für das Release-File

    36 my @DISTS	= qw/stable testing unstable/;			

    37 my @SECTIONS	= qw/main contrib non-free test/;

    38 my @BINARCHS	= qw/i386 ia64 amd64/;

    39 my @SRCARCHS	= qw/source/;

    40 

    41 my @ARCHS = (@SRCARCHS, @BINARCHS);

    42 

    43 my $Cf = new AppConfig (

    44     { CASE => 1 },

    45     "signed" =>             { ARGS => "!", DEFAULT => 1 },

    46     "remove-obsolete" =>    { ARGS => "!" },

    47     "verbose" =>	    { ARGS => ":i" },

    48     "stop" =>		    { ARGS => "=s", DEFAULT => "" },

    49     "force" =>		    { ARGS => "!" },

    50 );

    51 

    52 sub processChanges();

    53 sub getChanges();

    54 

    55 MAIN: {

    56 

    57     $Cf->getopt or die;

    58     $Cf->verbose(1) if defined $Cf->verbose && $Cf->verbose == 0;

    59     $Cf->verbose(0) if not defined $Cf->verbose;

    60 

    61     $| = 1;

    62 

    63     # absolutize the paths

    64     $LISTDIR = cwd() . "/$LISTDIR" if $LISTDIR !~ /^\//;

    65     $APTROOT = cwd() . "/$APTROOT" if $APTROOT !~ /^\//;

    66     $TIMESTAMP = cwd() . "/$TIMESTAMP" if $TIMESTAMP !~ /^\//;

    67 

    68     if (!$Cf->force) {

    69 	exit 0 if ((stat $TIMESTAMP)[9]||0) > ((stat "var/.import")[9]||0);

    70     }

    71 

    72     # create the dists/ hierarchy

    73     my $repos = new Debian::Repository {

    74 	root => $APTROOT,

    75 	origin => $ORIGIN,

    76 	dists => \@DISTS,

    77 	sections => \@SECTIONS,

    78 	binary => \@BINARCHS,,

    79 	source => \@SRCARCHS,

    80     };

    81 

    82     $repos->checkDirs(create => 1, umask => 022);

    83 

    84     chdir($_ = $repos->root) or die "Can't chdir to $_: $!\n";

    85 

    86     # Nun suchen wir die .changes-Files .... und verarbeiten 

    87     # diese.  Das muß erstmal getan werden, weil wir nur so wissen,

    88     # welches je Distribution/Architecture das jeweils neueste Paket

    89     # ist

    90     find({ wanted => sub { /\.changes$/ and processChanges(); }}, "pool/");

    91     print "\n" if -t STDIN;

    92 

    93     if ($Cf->stop eq "changes") {

    94 	if ($Cf->verbose) {

    95 	    while (my ($k, $chg) = getChanges()) { print "$k: ".$chg->key("version")."\n" }

    96 	}

    97 	exit 0;

    98     }

    99 

   100     # Nun gehen wir durch diese Liste der gefundenen Changes-Files

   101     # und erzeugen für jedes Paket einen Eintrag in der entsprechenden Liste

   102     # für das dann später loslaufende apt-ftparchive

   103     my (%LISTS, %KEEP);

   104     while (my ($k, $changes) = getChanges()) {

   105     #print "$k ($changes)\n";

   106     #next;

   107 

   108 	my $distribution = $changes->key("distribution");

   109 	print join(" " ,"$k:", $changes->keys(qw/source version/), $distribution, "\n")

   110 	    if -t STDIN;

   111 

   112 	$KEEP{$changes->path} = 1;

   113 

   114 	# Binary files (brauchen eine etwas andere Behandlung als die etwas weiter

   115 	# unten kommenden source Files

   116 	foreach my $file ($changes->binaryFiles) {

   117 

   118 	    # architectures is property of the each binary .deb file itself

   119 	    my $deb = new Debian::DebFile $file;

   120 	    my @archs = map { /^all$/ ? @BINARCHS : $_ } $deb->key("architecture");

   121 	    my $component = $file->component;

   122 

   123 	    foreach my $arch (@archs) {

   124 

   125 		my $tag = "$distribution.$component.$arch.list";

   126 		my $path = $file->path;

   127 

   128 		print "\t" . $file->file . " -> $tag\n" if -t STDIN;

   129 

   130 		$LISTS{$tag} = new IO::File $_ = ">$LISTDIR/$tag" or die "Can't open $_: $!\n"

   131 		    unless exists $LISTS{$tag};

   132 

   133 		$LISTS{$tag}->print("$path\n");

   134 

   135 		$KEEP{$path} = 1;

   136 	    }

   137 	}

   138 

   139 	foreach my $file ($changes->sourceFiles) {

   140 	    my $dsc = new Debian::ControlFile $file;

   141 

   142 	    my $path = $file->path;

   143 	    my $component = $file->component;

   144 	    my $tag = "$distribution.$component.source.list";

   145 

   146 	    print "\t" . $file->file . " -> $tag\n" if -t STDIN;

   147 	    

   148 	    $LISTS{$tag} = new IO::File $_ = ">$LISTDIR/$tag" or die "Can't open $_: $!\n"

   149 		unless exists $LISTS{$tag};

   150 

   151 	    $LISTS{$tag}->print("$path\n");

   152 

   153 	    $KEEP{$path} = ();

   154 	    @KEEP{map { $_->path } $dsc->files} = ();

   155 	}

   156     }

   157 

   158     # Nun wären wir mit den Listen eigentlich fertig, aber apt-ftparchive ist traurig, wenn

   159     # es eine Liste erwartet und es ist keine da. Also müssen wir auch für die Dinge, für die bisher

   160     # keine Liste angelegt wurde, diese Liste anlegen.

   161     # Da aktuell offenen Listen sowieso nicht mehr benötigt werden, schließen wir sie bei dieser

   162     # Gelegenheit gleich.

   163 

   164     foreach my $dist (@DISTS) { foreach my $sect (@SECTIONS) { foreach my $arch (@ARCHS) {

   165 	    my $tag = "$dist.$sect.$arch.list";

   166 

   167 	    my $fh;

   168 	    if (exists $LISTS{$tag}) {

   169 		$fh = $LISTS{$tag};

   170 		delete $LISTS{$tag};

   171 	    } else {

   172 		$fh = new IO::File ">$LISTDIR/$tag";

   173 	    }

   174 	    $fh->close;

   175     } } }

   176 

   177     exit 0 if $Cf->stop eq "lists";

   178 

   179     ## jetzt sind die File-Listen fertig erstellt und es wird Zeit, apt-ftparchive

   180     # aufzurufen

   181 

   182     if (!-t STDIN) {

   183 	open(SAVEOUT, ">&STDERR");

   184 	open(STDERR, ">/dev/null");

   185     }

   186 

   187     system("apt-ftparchive", generate => "$ENV{HOME}/etc/apt-ftparchive");

   188 

   189     open(STDERR, ">&SAVEOUT") if !-t STDOUT;

   190     close(SAVEOUT);

   191 

   192     if ($?) {

   193 	die "Problem running apt-ftparchive, exit was $?\n"

   194     }

   195 

   196     if ($Cf->signed) {

   197 	my $pid = fork();

   198 

   199 	if ($pid) {

   200 	    waitpid($pid, 0);

   201 	} 

   202 	else {

   203 	# Und nun die Release-Files

   204 	# Wir haben zwar schon welche dort liegen (die entstehen beim Pool-Repository

   205 	# einrichten, aber wenn wir mit Keys haben wollen, dann sind die dort nicht 

   206 	# ausreichend.

   207 	my $release_file = "Release";

   208 	my $release_sig = "$release_file.gpg";

   209 	foreach my $dist (@DISTS) {

   210 		my $dir = "$APTROOT/dists/$dist";

   211 

   212 		chdir $dir or die "Can't chdir to $dir: $!\n";

   213 

   214 		if (-f $release_file) {

   215 		    open(my $r, $release_file) or die "Can't open $release_file: $!\n";

   216 		    $_ = join "", grep { /^\S+:\s*\S.*$/ && !/^Date:/i } <$r>;

   217 		    close($r);

   218 

   219 		    if (!/^Suite:/ms && /^Release:\s*(\S+)$/ms) {

   220 			$_ .= "Suite: $1\n";

   221 		    }

   222 		}

   223 

   224 		# apt-ftparchive -> tmpfile

   225 		open(my $in, "apt-ftparchive release .|") or die "Problem running apt-ftparchive: $!\n";

   226 		my $out = new File::Temp(DIR => ".") or die "Can't create tmp file: $!\n";

   227 		print {$out} $_, grep !/ Release(?:\.gpg)?$/, <$in>; # das Release-File selbst ist da auch noch drin - weg damit

   228 		close($in) or die "Problem after running apt-ftparchive: $! ($?)";

   229 		close($out);

   230 

   231 		# Signatur -> tmpfile

   232 		my $sig = new File::Temp(DIR => ".");

   233 		open($in, "gpg --sign --armor --detach-sign --output - " . $out->filename . "|") or die "Problem running gpg: $!\n";

   234 		print {$sig} <$in>;

   235 		close($in) or die "Problem after running gpg: $! ($?)\n";

   236 		close($sig);

   237 

   238 		# tmpfiles -> Wirklichkeit

   239 		chmod(0644, $out->filename, $sig->filename);

   240 		rename($out->filename, $release_file) or die "Can't rename @{[$out->filename()]} to $release_file: $!\n";

   241 		rename($sig->filename, $release_sig) or die "Can't rename @{[$sig->filename()]} to $release_sig: $!\n";

   242 	    }

   243 	}

   244     }

   245 

   246     # Ok, und nun gehen wir noch mal durch den Baum und gucken nach Files, die nicht

   247     # mehr gebraucht werden

   248     find({wanted => sub {

   249 	return if not -f;

   250 	if (not exists $KEEP{$File::Find::name}) {

   251 	    # leave some notice to the importer

   252 

   253 	    if ($Cf->get("remove-obsolete")) {

   254 		unlink $_ or die "Can't unlink $File::Find::name: $!\n";

   255 		return;

   256 	    }

   257 	    print "-$File::Find::name\n" if -t STDIN;

   258 	    return;

   259 	}

   260 	print " $File::Find::name\n" if -t STDIN;

   261     }}, "pool/");

   262 

   263     # print "TO BE REMOVED:\n", join  "\n", map { $_->{file} } @OBSOLETE;

   264 

   265     open(X, ">$TIMESTAMP") or die "$TIMESTAMP: $!";

   266     print X $$;

   267     close(X);

   268 }

   269 

   270 # Watchout: Wir sitzen im Verzeichnis mit dem betroffenen File!

   271 # Darum übergeben wir noch den Prefix, damit wir das Verzeichnis später 

   272 # wiederfinden.

   273 {

   274     my %CHANGES;

   275 

   276 sub processChanges() {

   277     my $changes = new Debian::ChangesFile($_, path => $File::Find::name);

   278 

   279     # Nun rausfinden, ob wir noch ältere Files haben, die können wir dann

   280     # getrost ignorieren

   281 

   282     # Zuerst laufen wir durch gucken suchen uns die aktuellsten .changes-Files

   283     # raus (key ist source+distribution+architecture)

   284     # Ein Problem haben wir: Wenn die Archtektur sich ändert:

   285     #	1.2 i386

   286     #   2.0 all

   287     # -> also müssen wir für jede(!) Architektur ein Tag haben und ein aktuellstes

   288     # File.  (Aber aus 'all' machen wir die Liste der uns bekannten Architekturen

   289 

   290     print join(" ", $changes->keys(qw/source distribution version architecture/)), "\n" if $Cf->verbose > 1;

   291 

   292     foreach my $tag (map { join "^", $changes->keys(qw/source distribution/), $_ } $changes->archs) {

   293 

   294 	if (not exists($CHANGES{$tag})) {

   295 	    $CHANGES{$tag} = $changes;

   296 	    print "." if -t STDIN;

   297 	    next;

   298 	}

   299 

   300 	my $a = $CHANGES{$tag}->key("version");

   301 	my $b = $changes->key("version");

   302 

   303 	#printf "$tag: $a gt $b %d\n", Debian::Dpkg::compareVersions($a, "ge", $b);

   304 

   305 	if (Debian::Dpkg::compareVersions($a, "ge", $b)) {

   306 	    print "-" if -t STDIN;

   307 	    next;

   308 	}

   309 

   310 	$CHANGES{$tag} = $changes;

   311 	print "+" if -t STDIN;

   312 	print "replacing $tag $a => $b\n" if $Cf->verbose;

   313 	

   314     }

   315 

   316     return;

   317 } 

   318 

   319 sub getChanges() { return each(%CHANGES); }

   320 

   321 

   322 }

   323 

   324 # vim:sts=4 sw=4 aw ai sm: