X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?p=dgit.git;a=blobdiff_plain;f=dgit;h=8d4588fc3f93aea9baeb0dd4a58aaa23b047d9c6;hp=b13b5ed566c74f36d24a96298f59eb5e0ea007aa;hb=3fb6b8936cb3d476f3122a04c1fa2d9a3d911b7a;hpb=8293f64249970c85187371555ad7bd162a37d695

diff --git a/dgit b/dgit
index b13b5ed5..8d4588fc 100755
--- a/dgit
+++ b/dgit
@@ -30,6 +30,7 @@ use Dpkg::Version;
 use POSIX;
 use IPC::Open2;
 use Digest::SHA;
+use Digest::MD5;
 use Config;
 
 our $our_version = 'UNRELEASED'; ###substituted###
@@ -119,9 +120,14 @@ sub stripepoch ($) {
     return $vsn;
 }
 
+sub srcfn ($$) {
+    my ($vsn,$sfx) = @_;
+    return "${package}_".(stripepoch $vsn).$sfx
+}
+
 sub dscfn ($) {
     my ($vsn) = @_;
-    return "${package}_".(stripepoch $vsn).".dsc";
+    return srcfn($vsn,".dsc");
 }
 
 our $us = 'dgit';
@@ -510,13 +516,15 @@ our %defcfg = ('dgit.default.distro' => 'debian',
 	       'dgit.default.username' => '',
 	       'dgit.default.archive-query-default-component' => 'main',
 	       'dgit.default.ssh' => 'ssh',
+	       'dgit.default.archive-query' => 'madison:',
+	       'dgit.default.sshpsql-dbname' => 'service=projectb',
+	       'dgit-distro.debian.archive-query' => 'sshpsql:',
 	       'dgit-distro.debian.git-host' => 'git.debian.org',
 	       'dgit-distro.debian.git-proto' => 'git+ssh://',
 	       'dgit-distro.debian.git-path' => '/git/dgit-repos/repos',
 	       'dgit-distro.debian.git-check' => 'ssh-cmd',
 	       'dgit-distro.debian.git-create' => 'ssh-cmd',
 	       'dgit-distro.debian.sshpsql-host' => 'mirror.ftp-master.debian.org',
-	       'dgit-distro.debian.sshpsql-dbname' => 'service=projectb',
 	       'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
 	       'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
  'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
@@ -630,11 +638,14 @@ sub access_gituserhost () {
     return access_someuserhost('git');
 }
 
-sub access_giturl () {
+sub access_giturl (;$) {
+    my ($optional) = @_;
     my $url = access_cfg('git-url','RETURN-UNDEF');
     if (!defined $url) {
+	my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
+	return undef unless defined $proto;
 	$url =
-	    access_cfg('git-proto').
+	    $proto.
 	    access_gituserhost().
 	    access_cfg('git-path');
     }
@@ -722,16 +733,6 @@ our %rmad;
 sub archive_query ($) {
     my ($method) = @_;
     my $query = access_cfg('archive-query','RETURN-UNDEF');
-    if (!defined $query) {
-	my $distro = access_basedistro();
-	if ($distro eq 'debian') {
-	    $query = "sshpsql:".
-		access_someuserhost('sshpsql').':'.
-	        access_cfg('sshpsql-dbname');
-	} else {
-	    $query = "madison:$distro";
-	}
-    }
     $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
     my $proto = $1;
     my $data = $'; #';
@@ -744,17 +745,21 @@ sub pool_dsc_subpath ($$) {
     return "/pool/$component/$prefix/$package/".dscfn($vsn);
 }
 
-sub archive_query_madison ($$) {
+sub archive_query_madison {
+    return map { [ @$_[0..1] ] } madison_get_parse(@_);
+}
+
+sub madison_get_parse {
     my ($proto,$data) = @_;
     die unless $proto eq 'madison';
-    $rmad{$package} ||= cmdoutput
+    if (!length $data) {
+	$data= access_cfg('madison-distro','RETURN-UNDEF');
+	$data //= access_basedistro();
+    }
+    $rmad{$proto,$data,$package} ||= cmdoutput
 	qw(rmadison -asource),"-s$isuite","-u$data",$package;
-    my $rmad = $rmad{$package};
-    return madison_parse($rmad);
-}
+    my $rmad = $rmad{$proto,$data,$package};
 
-sub madison_parse ($) {
-    my ($rmad) = @_;
     my @out;
     foreach my $l (split /\n/, $rmad) {
 	$l =~ m{^ \s*( [^ \t|]+ )\s* \|
@@ -776,9 +781,9 @@ sub madison_parse ($) {
     return sort { -version_compare($a->[0],$b->[0]); } @out;
 }
 
-sub canonicalise_suite_madison ($$) {
+sub canonicalise_suite_madison {
     # madison canonicalises for us
-    my @r = archive_query_madison($_[0],$_[1]);
+    my @r = madison_get_parse(@_);
     @r or fail
 	"unable to canonicalise suite using package $package".
 	" which does not appear to exist in suite $isuite;".
@@ -788,6 +793,10 @@ sub canonicalise_suite_madison ($$) {
 
 sub sshpsql ($$) {
     my ($data,$sql) = @_;
+    if (!length $data) {
+	$data= access_someuserhost('sshpsql').':'.
+	    access_cfg('sshpsql-dbname');
+    }
     $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
     my ($userhost,$dbname) = ($`,$'); #';
     my @rows;
@@ -991,6 +1000,10 @@ sub mktree_in_ud_from_only_subdir () {
     changedir $dir;
     fail "source package contains .git directory" if stat_exists '.git';
     mktree_in_ud_here();
+    my $format=get_source_format();
+    if (madformat($format)) {
+	rmtree '.pc';
+    }
     runcmd @git, qw(add -Af);
     my $tree = cmdoutput @git, qw(write-tree);
     $tree =~ m/^\w+$/ or die "$tree ?";
@@ -1028,9 +1041,12 @@ sub dsc_files () {
     map { $_->{Filename} } dsc_files_info();
 }
 
-sub is_orig_file ($) {
-    local ($_) = @_;
-    m/\.orig(?:-\w+)?\.tar\.\w+$/;
+sub is_orig_file ($;$) {
+    local ($_) = $_[0];
+    my $base = $_[1];
+    m/\.orig(?:-\w+)?\.tar\.\w+$/ or return 0;
+    defined $base or return 1;
+    return $` eq $base;
 }
 
 sub make_commit ($) {
@@ -1314,11 +1330,14 @@ sub clone ($) {
     mkdir $dstdir or die "$dstdir $!";
     changedir $dstdir;
     runcmd @git, qw(init -q);
-    runcmd @git, qw(config), "remote.$remotename.fetch", fetchspec();
-    open H, "> .git/HEAD" or die $!;
-    print H "ref: ".lref()."\n" or die $!;
-    close H or die $!;
-    runcmd @git, qw(remote add), 'origin', access_giturl();
+    my $giturl = access_giturl(1);
+    if (defined $giturl) {
+	runcmd @git, qw(config), "remote.$remotename.fetch", fetchspec();
+	open H, "> .git/HEAD" or die $!;
+	print H "ref: ".lref()."\n" or die $!;
+	close H or die $!;
+	runcmd @git, qw(remote add), 'origin', $giturl;
+    }
     if (check_for_git()) {
 	progress "fetching existing git history";
 	git_fetch_us();
@@ -1363,6 +1382,12 @@ sub check_not_dirty () {
     }
 }
 
+sub commit_admin ($) {
+    my ($m) = @_;
+    progress "$m";
+    runcmd_ordryrun_local @git, qw(commit -m), $m;
+}
+
 sub commit_quilty_patch () {
     my $output = cmdoutput @git, qw(status --porcelain);
     my %adds;
@@ -1372,24 +1397,34 @@ sub commit_quilty_patch () {
 	    $adds{$1}++;
 	}
     }
+    delete $adds{'.pc'}; # if there wasn't one before, don't add it
     if (!%adds) {
 	progress "nothing quilty to commit, ok.";
 	return;
     }
     runcmd_ordryrun_local @git, qw(add), sort keys %adds;
-    my $m = "Commit Debian 3.0 (quilt) metadata";
-    progress "$m";
-    runcmd_ordryrun_local @git, qw(commit -m), $m;
+    commit_admin "Commit Debian 3.0 (quilt) metadata";
+}
+
+sub get_source_format () {
+    if (!open F, "debian/source/format") {
+	die $! unless $!==&ENOENT;
+	return '';
+    }
+    $_ = <F>;
+    F->error and die $!;
+    chomp;
+    return $_;
 }
 
 sub madformat ($) {
     my ($format) = @_;
     return 0 unless $format eq '3.0 (quilt)';
-    progress "Format \`$format', urgh";
     if ($noquilt) {
 	progress "Not doing any fixup of \`$format' due to --no-quilt-fixup";
 	return 0;
     }
+    progress "Format \`$format', checking/updating patch stack";
     return 1;
 }
 
@@ -1940,30 +1975,124 @@ our $dscfn;
 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
 
 sub build_maybe_quilt_fixup () {
-    if (!open F, "debian/source/format") {
-	die $! unless $!==&ENOENT;
-	return;
-    }
-    $_ = <F>;
-    F->error and die $!;
-    chomp;
-    return unless madformat($_);
+    my $format=get_source_format;
+    return unless madformat $format;
     # sigh
-    
-    my @cmd = (@git, qw(ls-files --exclude-standard -iodm));
-    my $problems = cmdoutput @cmd;
-    if (length $problems) {
-	print STDERR "problematic files:\n";
-	print STDERR "  $_\n" foreach split /\n/, $problems;
-	fail "Cannot do quilt fixup in tree containing ignored files.  ".
-	    "Perhaps your package's clean target is broken, in which".
-	    " case -wg (which says to use git-clean -xdf) may help.";
-    }
+
+    # Our objective is:
+    #  - honour any existing .pc in case it has any strangeness
+    #  - determine the git commit corresponding to the tip of
+    #    the patch stack (if there is one)
+    #  - if there is such a git commit, convert each subsequent
+    #    git commit into a quilt patch with dpkg-source --commit
+    #  - otherwise convert all the differences in the tree into
+    #    a single git commit
+    #
+    # To do this we:
+
+    # Our git tree doesn't necessarily contain .pc.  (Some versions of
+    # dgit would include the .pc in the git tree.)  If there isn't
+    # one, we need to generate one by unpacking the patches that we
+    # have.
+    #
+    # We first look for a .pc in the git tree.  If there is one, we
+    # will use it.  (This is not the normal case.)
+    #
+    # Otherwise need to regenerate .pc so that dpkg-source --commit
+    # can work.  We do this as follows:
+    #     1. Collect all relevant .orig from parent directory
+    #     2. Generate a debian.tar.gz out of
+    #         debian/{patches,rules,source/format}
+    #     3. Generate a fake .dsc containing just these fields:
+    #          Format Source Version Files
+    #     4. Extract the fake .dsc
+    #        Now the fake .dsc has a .pc directory.
+    # (In fact we do this in every case, because in future we will
+    # want to search for a good base commit for generating patches.)
+    #
+    # Then we can actually do the dpkg-source --commit
+    #     1. Make a new working tree with the same object
+    #        store as our main tree and check out the main
+    #        tree's HEAD.
+    #     2. Copy .pc from the fake's extraction, if necessary
+    #     3. Run dpkg-source --commit
+    #     4. If the result has changes to debian/, then
+    #          - git-add them them
+    #          - git-add .pc if we had a .pc in-tree
+    #          - git-commit
+    #     5. If we had a .pc in-tree, delete it, and git-commit
+    #     6. Back in the main tree, fast forward to the new HEAD
 
     my $clogp = parsechangelog();
-    my $version = getfield $clogp, 'Version';
-    my $author = getfield $clogp, 'Maintainer';
     my $headref = rev_parse('HEAD');
+
+    prep_ud();
+    changedir $ud;
+
+    my $upstreamversion=$version;
+    $upstreamversion =~ s/-[^-]*$//;
+
+    my $fakeversion="$upstreamversion-~~DGITFAKE";
+
+    my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
+    print $fakedsc <<END or die $!;
+Format: 3.0 (quilt)
+Source: $package
+Version: $fakeversion
+Files:
+END
+
+    my $dscaddfile=sub {
+        my ($b) = @_;
+        
+	my $md = new Digest::MD5;
+
+	my $fh = new IO::File $b, '<' or die "$b $!";
+	stat $fh or die $!;
+	my $size = -s _;
+
+	$md->addfile($fh);
+	print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
+    };
+
+    foreach my $f (<../../../../*>) { #/){
+	my $b=$f; $b =~ s{.*/}{};
+	next unless is_orig_file $b, srcfn $upstreamversion,'';
+	link $f, $b or die "$b $!";
+        $dscaddfile->($b);
+    }
+
+    my @files=qw(debian/source/format debian/rules);
+    if (stat_exists '../../../debian/patches') {
+        push @files, 'debian/patches';
+    }
+
+    my $debtar= srcfn $fakeversion,'.debian.tar.gz';
+    runcmd qw(env GZIP=-1 tar -zcf), "./$debtar", qw(-C ../../..), @files;
+
+    $dscaddfile->($debtar);
+    close $fakedsc or die $!;
+
+    runcmd qw(sh -ec), 'exec dpkg-source --no-check -x fake.dsc >/dev/null';
+
+    my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
+    rename $fakexdir, "fake" or die "$fakexdir $!";
+
+    mkdir "work" or die $!;
+    changedir "work";
+    mktree_in_ud_here();
+    runcmd @git, qw(reset --hard), $headref;
+
+    my $mustdeletepc=0;
+    if (stat_exists ".pc") {
+        -d _ or die;
+	progress "Tree already contains .pc - will use it then delete it.";
+        $mustdeletepc=1;
+    } else {
+        rename '../fake/.pc','.pc' or die $!;
+    }
+
+    my $author = getfield $clogp, 'Maintainer';
     my $time = time;
     my $ncommits = 3;
     my $patchname = "auto-$version-$headref-$time";
@@ -1998,6 +2127,14 @@ END
     }
 
     commit_quilty_patch();
+
+    if ($mustdeletepc) {
+        runcmd @git, qw(rm -rq .pc);
+        commit_admin "Commit removal of .pc (quilt series tracking data)";
+    }
+
+    changedir '../../../..';
+    runcmd @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
 }
 
 sub quilt_fixup_editor () {
@@ -2152,6 +2289,7 @@ sub cmd_quilt_fixup {
     badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
     my $clogp = parsechangelog();
     $version = getfield $clogp, 'Version';
+    $package = getfield $clogp, 'Source';
     build_maybe_quilt_fixup();
 }