File mkdrpms of Package build

#!/usr/bin/perl -w

################################################################
#
# Copyright (c) 1995-2014 SUSE Linux Products GmbH
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License version 2 or 3 as
# published by the Free Software Foundation.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program (see the file COPYING); if not, write to the
# Free Software Foundation, Inc.,
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
#
################################################################

BEGIN {
  unshift @INC, '/usr/lib/build';
  unshift @INC, $::ENV{'BUILD_DIR'} if $::ENV{'BUILD_DIR'};
}

use Build;
use strict;

my $limit = 80; # throw away deltas bigger than this percentage of the reference
my %oldpkgs;

sub query {
    my ($file) = @_;

    return undef if $file =~ /\.(?:patch|delta)\.rpm$/; # XXX: rpmtags?
    my %res = Build::Rpm::rpmq($file, qw/NAME EPOCH VERSION RELEASE ARCH SOURCERPM NOSOURCE NOPATCH 1124/);
    return undef unless %res;
    return undef if $res{'1124'}->[0] && $res{'1124'}->[0] eq 'drpm';
    my $arch;
    if ($res{'SOURCERPM'}->[0]) {
	$arch = $res{'ARCH'}->[0];
    } else {
        # no src rpm deltas for now
#	if ($res{'NOSOURCE'}->[0] || $res{'NOPATCH'}->[0]) {
#	    $arch = 'nosrc';
#	} else {
#	    $arch = 'src';
#	}
	return undef;
    }
    return { file => $file, name => $res{'NAME'}->[0], epoch => $res{'EPOCH'} ? $res{'EPOCH'}->[0] : '', version => $res{'VERSION'}->[0], release => $res{'RELEASE'}->[0], arch => $arch};
}

sub lsrpms {
    local *D; 
    if (-f "$_[0]") {
      return ($_[0]) if $_[0] =~ /\.rpm$/;
      return ();
    }
    opendir(D, $_[0]) || return (); 
    my @r = grep {$_ ne '.' && $_ ne '..'} readdir(D);
    closedir D;
    return map {"$_[0]/$_"} grep {/\.rpm$/} sort(@r);
}

while (@ARGV) {
    if ($ARGV[0] eq '--limit') {
	shift @ARGV;
	die("--limit needs an argument\n") unless @ARGV;
	$limit = shift @ARGV;
	next;
    }
    last;
}

my $prevbuild = shift @ARGV || die "USAGE: $0 <oldpkgdir> <directories...>";
my @prevbuild = ($prevbuild);
my $i = 1;
while (-d $prevbuild.$i) {
    push @prevbuild, $prevbuild.$i;
    ++$i;
}
for my $dir (@prevbuild) {
    for my $file (lsrpms($dir)) {
	my $q = query($file);
	next unless $q;
	my $n = $q->{'name'}.'.'.$q->{'arch'};
	push @{$oldpkgs{$n}}, $q;
    }
}

my $sysret = 0;
for my $dir (@ARGV) {
    for my $file (lsrpms($dir)) {
	my $q = query($file);
	next unless $q;
	next if $q->{'arch'} eq 'src' || $q->{'arch'} eq 'nosrc';
	next if $q->{'name'} =~  /-debug(:?info|source)/;	# no debug deltas
	my $n = $q->{'name'}.'.'.$q->{'arch'};
        
	for my $oq (@{$oldpkgs{$n} || []}) {
	    my $v = $oq->{'version'};
	    my $r = $oq->{'release'};
	    if ($v eq $q->{'version'} && $r eq $q->{'release'}) {
		# skip if same version and release
		next;
	    }
	    $v .= '_'.$q->{'version'} unless $v eq $q->{'version'};
	    $r .= '_'.$q->{'release'} unless $r eq $q->{'release'};
	    my $dn = sprintf("%s-%s-%s.%s.drpm", $q->{'name'}, $v, $r, $q->{'arch'});
	    my $sn = sprintf("%s-%s-%s.%s.dseq", $q->{'name'}, $v, $r, $q->{'arch'});
	    print "$dn ... ";
	    my $dndir = $q->{'file'};
	    $dndir =~ s/[^\/]+$//s;
	    $dn = "$dndir$dn";
	    my $ret = system('makedeltarpm', '-s', $sn, $oq->{'file'}, $q->{'file'}, $dn);
	    if ($ret || ! -e $dn) {
		unlink($dn);
		unlink($sn);
		print "FAILED\n";
		$sysret = 1;
	    } else {
		my $ns = (stat($dn))[7] || 1;
		my $os = (stat($q->{'file'}))[7] || 1;
		my $factor = int($ns / $os * 100);
		if ($factor > $limit) {
		    print "too big ($factor%), removed\n";
		    unlink($dn);
		    unlink($sn);
		} else {
		    local *F;
		    my $seq = '';
		    if (!open(F, '<', $sn)) {
			print "missing sequence file, removed\n";
			unlink($dn);
			unlink($sn);
			next;
		    }
		    1 while sysread(F, $seq, 8192, length($seq));
		    close F;
		    chomp $seq;
		    unlink($sn);
		    $seq = "Name: $q->{'name'}\nEpoch: $q->{'epoch'}\nVersion: $q->{'version'}\nRelease: $q->{'release'}\nArch: $q->{'arch'}\nOldName: $oq->{'name'}\nOldEpoch: $oq->{'epoch'}\nOldVersion: $oq->{'version'}\nOldRelease: $oq->{'release'}\nOldArch: $oq->{'arch'}\nSeq: $seq\n";
		    if (!open(F, '>', $sn) || syswrite(F, $seq) != length($seq) || !close(F)) {
			print "sequence file write error, removed\n";
			unlink($dn);
			unlink($sn);
			next;
		    }
		    print "ok ($factor%)\n";
		}
	    }
	}
    }
}

exit $sysret;